(iso-2022-control-alist): New variable.
[bpt/emacs.git] / lisp / simple.el
CommitLineData
c88ab9ce
ER
1;;; simple.el --- basic editing commands for Emacs
2
a0184aeb 3;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 1999
69c1dd37 4;; Free Software Foundation, Inc.
2076c87c
JB
5
6;; This file is part of GNU Emacs.
7
8;; GNU Emacs is free software; you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
3a801d0c 10;; the Free Software Foundation; either version 2, or (at your option)
2076c87c
JB
11;; any later version.
12
13;; GNU Emacs is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;; GNU General Public License for more details.
17
18;; You should have received a copy of the GNU General Public License
b578f267
EN
19;; along with GNU Emacs; see the file COPYING. If not, write to the
20;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21;; Boston, MA 02111-1307, USA.
2076c87c 22
d9ecc911
ER
23;;; Commentary:
24
25;; A grab-bag of basic Emacs commands not specifically related to some
26;; major mode or to file-handling.
27
3a801d0c 28;;; Code:
2076c87c 29
69c1dd37
RS
30(defgroup killing nil
31 "Killing and yanking commands"
32 :group 'editing)
33
34(defgroup fill-comments nil
35 "Indenting and filling of comments."
36 :prefix "comment-"
37 :group 'fill)
38
39(defgroup paren-matching nil
40 "Highlight (un)matching of parens and expressions."
69c1dd37
RS
41 :group 'matching)
42
43
30bb9754 44(defun newline (&optional arg)
d133d835 45 "Insert a newline, and move to left margin of the new line if it's blank.
30bb9754
BG
46The newline is marked with the text-property `hard'.
47With arg, insert that many newlines.
48In Auto Fill mode, if no numeric arg, break the preceding line if it's long."
49 (interactive "*P")
4c4cbf11 50 (barf-if-buffer-read-only)
30bb9754
BG
51 ;; Inserting a newline at the end of a line produces better redisplay in
52 ;; try_window_id than inserting at the beginning of a line, and the textual
53 ;; result is the same. So, if we're at beginning of line, pretend to be at
54 ;; the end of the previous line.
55 (let ((flag (and (not (bobp))
56 (bolp)
1cd24721
RS
57 ;; Make sure no functions want to be told about
58 ;; the range of the changes.
59 (not after-change-function)
60 (not before-change-function)
61 (not after-change-functions)
62 (not before-change-functions)
fd977703
RS
63 ;; Make sure there are no markers here.
64 (not (buffer-has-markers-at (1- (point))))
2f047f6c 65 (not (buffer-has-markers-at (point)))
1cd24721
RS
66 ;; Make sure no text properties want to know
67 ;; where the change was.
68 (not (get-char-property (1- (point)) 'modification-hooks))
69 (not (get-char-property (1- (point)) 'insert-behind-hooks))
70 (or (eobp)
71 (not (get-char-property (point) 'insert-in-front-hooks)))
31a5333f
MB
72 ;; Make sure the newline before point isn't intangible.
73 (not (get-char-property (1- (point)) 'intangible))
74 ;; Make sure the newline before point isn't read-only.
75 (not (get-char-property (1- (point)) 'read-only))
76 ;; Make sure the newline before point isn't invisible.
77 (not (get-char-property (1- (point)) 'invisible))
78 ;; Make sure the newline before point has the same
79 ;; properties as the char before it (if any).
30bb9754 80 (< (or (previous-property-change (point)) -2)
d133d835
RS
81 (- (point) 2))))
82 (was-page-start (and (bolp)
83 (looking-at page-delimiter)))
84 (beforepos (point)))
30bb9754
BG
85 (if flag (backward-char 1))
86 ;; Call self-insert so that auto-fill, abbrev expansion etc. happens.
87 ;; Set last-command-char to tell self-insert what to insert.
88 (let ((last-command-char ?\n)
89 ;; Don't auto-fill if we have a numeric argument.
3954fff9
RS
90 ;; Also not if flag is true (it would fill wrong line);
91 ;; there is no need to since we're at BOL.
92 (auto-fill-function (if (or arg flag) nil auto-fill-function)))
4cc9d0dc
RS
93 (unwind-protect
94 (self-insert-command (prefix-numeric-value arg))
95 ;; If we get an error in self-insert-command, put point at right place.
96 (if flag (forward-char 1))))
2f047f6c
KH
97 ;; Even if we did *not* get an error, keep that forward-char;
98 ;; all further processing should apply to the newline that the user
99 ;; thinks he inserted.
100
30bb9754
BG
101 ;; Mark the newline(s) `hard'.
102 (if use-hard-newlines
2f047f6c 103 (set-hard-newline-properties
55741b46 104 (- (point) (if arg (prefix-numeric-value arg) 1)) (point)))
d133d835
RS
105 ;; If the newline leaves the previous line blank,
106 ;; and we have a left margin, delete that from the blank line.
107 (or flag
108 (save-excursion
109 (goto-char beforepos)
110 (beginning-of-line)
111 (and (looking-at "[ \t]$")
112 (> (current-left-margin) 0)
113 (delete-region (point) (progn (end-of-line) (point))))))
d133d835
RS
114 ;; Indent the line after the newline, except in one case:
115 ;; when we added the newline at the beginning of a line
116 ;; which starts a page.
117 (or was-page-start
118 (move-to-left-margin nil t)))
30bb9754
BG
119 nil)
120
55741b46
RS
121(defun set-hard-newline-properties (from to)
122 (let ((sticky (get-text-property from 'rear-nonsticky)))
123 (put-text-property from to 'hard 't)
124 ;; If rear-nonsticky is not "t", add 'hard to rear-nonsticky list
125 (if (and (listp sticky) (not (memq 'hard sticky)))
126 (put-text-property from (point) 'rear-nonsticky
127 (cons 'hard sticky)))))
128
2076c87c 129(defun open-line (arg)
ff1fbe3e 130 "Insert a newline and leave point before it.
3db1e3b5 131If there is a fill prefix and/or a left-margin, insert them on the new line
d133d835 132if the line would have been blank.
616ed245 133With arg N, insert N newlines."
2076c87c 134 (interactive "*p")
616ed245 135 (let* ((do-fill-prefix (and fill-prefix (bolp)))
3db1e3b5 136 (do-left-margin (and (bolp) (> (current-left-margin) 0)))
28191e20 137 (loc (point)))
d133d835
RS
138 (newline arg)
139 (goto-char loc)
28191e20 140 (while (> arg 0)
d133d835
RS
141 (cond ((bolp)
142 (if do-left-margin (indent-to (current-left-margin)))
143 (if do-fill-prefix (insert-and-inherit fill-prefix))))
144 (forward-line 1)
28191e20 145 (setq arg (1- arg)))
d133d835
RS
146 (goto-char loc)
147 (end-of-line)))
2076c87c
JB
148
149(defun split-line ()
150 "Split current line, moving portion beyond point vertically down."
151 (interactive "*")
152 (skip-chars-forward " \t")
153 (let ((col (current-column))
154 (pos (point)))
28191e20 155 (newline 1)
2076c87c
JB
156 (indent-to col 0)
157 (goto-char pos)))
158
159(defun quoted-insert (arg)
160 "Read next input character and insert it.
ff1fbe3e 161This is useful for inserting control characters.
37fb0200
RS
162
163If the first character you type after this command is an octal digit,
164you should type a sequence of octal digits which specify a character code.
037a2961 165Any nondigit terminates the sequence. If the terminator is a RET,
37fb0200 166it is discarded; any other terminator is used itself as input.
037a2961
RS
167The variable `read-quoted-char-radix' specifies the radix for this feature;
168set it to 10 or 16 to use decimal or hex instead of octal.
b6a22db0
JB
169
170In overwrite mode, this function inserts the character anyway, and
171does not handle octal digits specially. This means that if you use
172overwrite as your normal editing mode, you can use this function to
173insert characters when necessary.
174
175In binary overwrite mode, this function does overwrite, and octal
37fb0200
RS
176digits are interpreted as a character code. This is intended to be
177useful for editing binary files."
2076c87c 178 (interactive "*p")
b6a22db0
JB
179 (let ((char (if (or (not overwrite-mode)
180 (eq overwrite-mode 'overwrite-mode-binary))
181 (read-quoted-char)
182 (read-char))))
5280b595
KH
183 ;; Assume character codes 0240 - 0377 stand for characters in some
184 ;; single-byte character set, and convert them to Emacs
185 ;; characters.
186 (if (and enable-multibyte-characters
187 (>= char ?\240)
188 (<= char ?\377))
189 (setq char (unibyte-char-to-multibyte char)))
ec321cad
RS
190 (if (> arg 0)
191 (if (eq overwrite-mode 'overwrite-mode-binary)
192 (delete-char arg)))
193 (while (> arg 0)
194 (insert-and-inherit char)
195 (setq arg (1- arg)))))
2076c87c
JB
196
197(defun delete-indentation (&optional arg)
198 "Join this line to previous and fix up whitespace at join.
ccc58657 199If there is a fill prefix, delete it from the beginning of this line.
2076c87c
JB
200With argument, join this line to following line."
201 (interactive "*P")
202 (beginning-of-line)
203 (if arg (forward-line 1))
204 (if (eq (preceding-char) ?\n)
205 (progn
206 (delete-region (point) (1- (point)))
ccc58657
RS
207 ;; If the second line started with the fill prefix,
208 ;; delete the prefix.
209 (if (and fill-prefix
01b8e020 210 (<= (+ (point) (length fill-prefix)) (point-max))
ccc58657
RS
211 (string= fill-prefix
212 (buffer-substring (point)
213 (+ (point) (length fill-prefix)))))
214 (delete-region (point) (+ (point) (length fill-prefix))))
2076c87c
JB
215 (fixup-whitespace))))
216
fc025090
DL
217(defalias 'join-line #'delete-indentation) ; easier to find
218
2076c87c
JB
219(defun fixup-whitespace ()
220 "Fixup white space between objects around point.
221Leave one space or none, according to the context."
222 (interactive "*")
223 (save-excursion
224 (delete-horizontal-space)
225 (if (or (looking-at "^\\|\\s)")
226 (save-excursion (forward-char -1)
227 (looking-at "$\\|\\s(\\|\\s'")))
228 nil
229 (insert ?\ ))))
230
231(defun delete-horizontal-space ()
232 "Delete all spaces and tabs around point."
233 (interactive "*")
234 (skip-chars-backward " \t")
235 (delete-region (point) (progn (skip-chars-forward " \t") (point))))
236
237(defun just-one-space ()
238 "Delete all spaces and tabs around point, leaving one space."
239 (interactive "*")
240 (skip-chars-backward " \t")
241 (if (= (following-char) ? )
242 (forward-char 1)
243 (insert ? ))
244 (delete-region (point) (progn (skip-chars-forward " \t") (point))))
245
246(defun delete-blank-lines ()
247 "On blank line, delete all surrounding blank lines, leaving just one.
248On isolated blank line, delete that one.
6d30d416 249On nonblank line, delete any immediately following blank lines."
2076c87c
JB
250 (interactive "*")
251 (let (thisblank singleblank)
252 (save-excursion
253 (beginning-of-line)
254 (setq thisblank (looking-at "[ \t]*$"))
70e14c01 255 ;; Set singleblank if there is just one blank line here.
2076c87c
JB
256 (setq singleblank
257 (and thisblank
258 (not (looking-at "[ \t]*\n[ \t]*$"))
259 (or (bobp)
260 (progn (forward-line -1)
261 (not (looking-at "[ \t]*$")))))))
70e14c01 262 ;; Delete preceding blank lines, and this one too if it's the only one.
2076c87c
JB
263 (if thisblank
264 (progn
265 (beginning-of-line)
266 (if singleblank (forward-line 1))
267 (delete-region (point)
268 (if (re-search-backward "[^ \t\n]" nil t)
269 (progn (forward-line 1) (point))
270 (point-min)))))
70e14c01
JB
271 ;; Delete following blank lines, unless the current line is blank
272 ;; and there are no following blank lines.
2076c87c
JB
273 (if (not (and thisblank singleblank))
274 (save-excursion
275 (end-of-line)
276 (forward-line 1)
277 (delete-region (point)
278 (if (re-search-forward "[^ \t\n]" nil t)
279 (progn (beginning-of-line) (point))
70e14c01
JB
280 (point-max)))))
281 ;; Handle the special case where point is followed by newline and eob.
282 ;; Delete the line, leaving point at eob.
283 (if (looking-at "^[ \t]*\n\\'")
284 (delete-region (point) (point-max)))))
2076c87c
JB
285
286(defun back-to-indentation ()
287 "Move point to the first non-whitespace character on this line."
288 (interactive)
289 (beginning-of-line 1)
290 (skip-chars-forward " \t"))
291
292(defun newline-and-indent ()
293 "Insert a newline, then indent according to major mode.
ff1fbe3e 294Indentation is done using the value of `indent-line-function'.
2076c87c 295In programming language modes, this is the same as TAB.
ff1fbe3e 296In some text modes, where TAB inserts a tab, this command indents to the
eed5698b 297column specified by the function `current-left-margin'."
2076c87c
JB
298 (interactive "*")
299 (delete-region (point) (progn (skip-chars-backward " \t") (point)))
46947372 300 (newline)
2076c87c
JB
301 (indent-according-to-mode))
302
303(defun reindent-then-newline-and-indent ()
304 "Reindent current line, insert newline, then indent the new line.
305Indentation of both lines is done according to the current major mode,
ff1fbe3e 306which means calling the current value of `indent-line-function'.
2076c87c
JB
307In programming language modes, this is the same as TAB.
308In some text modes, where TAB inserts a tab, this indents to the
eed5698b 309column specified by the function `current-left-margin'."
2076c87c
JB
310 (interactive "*")
311 (save-excursion
312 (delete-region (point) (progn (skip-chars-backward " \t") (point)))
313 (indent-according-to-mode))
46947372 314 (newline)
2076c87c
JB
315 (indent-according-to-mode))
316
dff7d67f
RS
317;; Internal subroutine of delete-char
318(defun kill-forward-chars (arg)
319 (if (listp arg) (setq arg (car arg)))
320 (if (eq arg '-) (setq arg -1))
d5d99b80 321 (kill-region (point) (forward-point arg)))
dff7d67f
RS
322
323;; Internal subroutine of backward-delete-char
324(defun kill-backward-chars (arg)
325 (if (listp arg) (setq arg (car arg)))
326 (if (eq arg '-) (setq arg -1))
d5d99b80 327 (kill-region (point) (forward-point (- arg))))
dff7d67f 328
cc2b2b6c
RS
329(defcustom backward-delete-char-untabify-method 'untabify
330 "*The method for untabifying when deleting backward.
331Can be `untabify' -- turn a tab to many spaces, then delete one space.
332 `hungry' -- delete all whitespace, both tabs and spaces.
333 nil -- just delete one character."
334 :type '(choice (const untabify) (const hungry) (const nil))
335 :group 'killing)
336
2076c87c
JB
337(defun backward-delete-char-untabify (arg &optional killp)
338 "Delete characters backward, changing tabs into spaces.
cc2b2b6c 339The exact behavior depends on `backward-delete-char-untabify-method'.
2076c87c
JB
340Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
341Interactively, ARG is the prefix arg (default 1)
aba05ae4 342and KILLP is t if a prefix arg was specified."
2076c87c 343 (interactive "*p\nP")
cc2b2b6c 344 (when (eq backward-delete-char-untabify-method 'untabify)
dbe524b6
RS
345 (let ((count arg))
346 (save-excursion
347 (while (and (> count 0) (not (bobp)))
348 (if (= (preceding-char) ?\t)
349 (let ((col (current-column)))
350 (forward-char -1)
351 (setq col (- col (current-column)))
352 (insert-char ?\ col)
353 (delete-char 1)))
354 (forward-char -1)
355 (setq count (1- count))))))
cc2b2b6c
RS
356 (delete-backward-char
357 (if (eq backward-delete-char-untabify-method 'hungry)
358 (let ((wh (- (point) (save-excursion (skip-chars-backward " \t")
359 (point)))))
360 (+ arg (if (zerop wh) 0 (1- wh))))
361 arg)
362 killp))
2076c87c
JB
363
364(defun zap-to-char (arg char)
365 "Kill up to and including ARG'th occurrence of CHAR.
366Goes backward if ARG is negative; error if CHAR not found."
367 (interactive "p\ncZap to char: ")
368 (kill-region (point) (progn
369 (search-forward (char-to-string char) nil nil arg)
370; (goto-char (if (> arg 0) (1- (point)) (1+ (point))))
371 (point))))
372
373(defun beginning-of-buffer (&optional arg)
374 "Move point to the beginning of the buffer; leave mark at previous position.
c66587fe
RS
375With arg N, put point N/10 of the way from the beginning.
376
377If the buffer is narrowed, this command uses the beginning and size
378of the accessible part of the buffer.
ff1fbe3e
RS
379
380Don't use this command in Lisp programs!
2076c87c
JB
381\(goto-char (point-min)) is faster and avoids clobbering the mark."
382 (interactive "P")
383 (push-mark)
c66587fe
RS
384 (let ((size (- (point-max) (point-min))))
385 (goto-char (if arg
386 (+ (point-min)
387 (if (> size 10000)
388 ;; Avoid overflow for large buffer sizes!
389 (* (prefix-numeric-value arg)
390 (/ size 10))
391 (/ (+ 10 (* size (prefix-numeric-value arg))) 10)))
392 (point-min))))
2076c87c
JB
393 (if arg (forward-line 1)))
394
395(defun end-of-buffer (&optional arg)
396 "Move point to the end of the buffer; leave mark at previous position.
c66587fe
RS
397With arg N, put point N/10 of the way from the end.
398
399If the buffer is narrowed, this command uses the beginning and size
400of the accessible part of the buffer.
ff1fbe3e
RS
401
402Don't use this command in Lisp programs!
2076c87c
JB
403\(goto-char (point-max)) is faster and avoids clobbering the mark."
404 (interactive "P")
405 (push-mark)
c66587fe
RS
406 (let ((size (- (point-max) (point-min))))
407 (goto-char (if arg
408 (- (point-max)
409 (if (> size 10000)
410 ;; Avoid overflow for large buffer sizes!
411 (* (prefix-numeric-value arg)
412 (/ size 10))
413 (/ (* size (prefix-numeric-value arg)) 10)))
414 (point-max))))
3a801d0c
ER
415 ;; If we went to a place in the middle of the buffer,
416 ;; adjust it to the beginning of a line.
2076c87c 417 (if arg (forward-line 1)
3a801d0c
ER
418 ;; If the end of the buffer is not already on the screen,
419 ;; then scroll specially to put it near, but not at, the bottom.
420 (if (let ((old-point (point)))
421 (save-excursion
422 (goto-char (window-start))
423 (vertical-motion (window-height))
424 (< (point) old-point)))
97dfc68c
RS
425 (progn
426 (overlay-recenter (point))
427 (recenter -3)))))
2076c87c
JB
428
429(defun mark-whole-buffer ()
70e14c01
JB
430 "Put point at beginning and mark at end of buffer.
431You probably should not use this function in Lisp programs;
432it is usually a mistake for a Lisp function to use any subroutine
433that uses or sets the mark."
2076c87c
JB
434 (interactive)
435 (push-mark (point))
fd0f4056 436 (push-mark (point-max) nil t)
2076c87c
JB
437 (goto-char (point-min)))
438
439(defun count-lines-region (start end)
eb8c3be9 440 "Print number of lines and characters in the region."
2076c87c
JB
441 (interactive "r")
442 (message "Region has %d lines, %d characters"
443 (count-lines start end) (- end start)))
444
445(defun what-line ()
2578be76 446 "Print the current buffer line number and narrowed line number of point."
2076c87c 447 (interactive)
2578be76 448 (let ((opoint (point)) start)
2076c87c 449 (save-excursion
2578be76
RS
450 (save-restriction
451 (goto-char (point-min))
452 (widen)
453 (beginning-of-line)
454 (setq start (point))
455 (goto-char opoint)
456 (beginning-of-line)
457 (if (/= start 1)
458 (message "line %d (narrowed line %d)"
459 (1+ (count-lines 1 (point)))
460 (1+ (count-lines start (point))))
461 (message "Line %d" (1+ (count-lines 1 (point)))))))))
462
2076c87c
JB
463
464(defun count-lines (start end)
465 "Return number of lines between START and END.
466This is usually the number of newlines between them,
ff1fbe3e 467but can be one more if START is not equal to END
2076c87c 468and the greater of them is not at the start of a line."
e406700d
RS
469 (save-excursion
470 (save-restriction
471 (narrow-to-region start end)
472 (goto-char (point-min))
473 (if (eq selective-display t)
474 (save-match-data
dde92ca6
RS
475 (let ((done 0))
476 (while (re-search-forward "[\n\C-m]" nil t 40)
477 (setq done (+ 40 done)))
478 (while (re-search-forward "[\n\C-m]" nil t 1)
479 (setq done (+ 1 done)))
043efc41
RS
480 (goto-char (point-max))
481 (if (and (/= start end)
482 (not (bolp)))
483 (1+ done)
e406700d
RS
484 done)))
485 (- (buffer-size) (forward-line (buffer-size)))))))
2076c87c 486
d5d99b80
KH
487(defun what-cursor-position (&optional detail)
488 "Print info on cursor position (on screen and within buffer).
e38dff0c 489Also describe the character after point, and give its character code
c6fcc518
KH
490in octal, decimal and hex.
491
492For a non-ASCII multibyte character, also give its encoding in the
493buffer's selected coding system if the coding system encodes the
494character safely. If the character is encoded into one byte, that
495code is shown in hex. If the character is encoded into more than one
496byte, just \"...\" is shown.
e5a902cf 497
e38dff0c
RS
498With prefix argument, print additional details about that character,
499instead of the cursor position. This includes the character set name,
c6fcc518
KH
500the codes that identify the character within that character set. In
501addition, the encoding is fully shown."
d5d99b80 502 (interactive "P")
2076c87c
JB
503 (let* ((char (following-char))
504 (beg (point-min))
505 (end (point-max))
506 (pos (point))
507 (total (buffer-size))
508 (percent (if (> total 50000)
509 ;; Avoid overflow from multiplying by 100!
510 (/ (+ (/ total 200) (1- pos)) (max (/ total 100) 1))
511 (/ (+ (/ total 2) (* 100 (1- pos))) (max total 1))))
512 (hscroll (if (= (window-hscroll) 0)
513 ""
514 (format " Hscroll=%d" (window-hscroll))))
515 (col (current-column)))
516 (if (= pos end)
517 (if (or (/= beg 1) (/= end (1+ total)))
518 (message "point=%d of %d(%d%%) <%d - %d> column %d %s"
519 pos total percent beg end col hscroll)
520 (message "point=%d of %d(%d%%) column %d %s"
521 pos total percent col hscroll))
c6fcc518
KH
522 (let ((coding buffer-file-coding-system)
523 encoded encoding-msg)
524 (if (or (not coding)
525 (eq (coding-system-type coding) t))
526 (setq coding default-buffer-file-coding-system))
527 (setq encoded (and (>= char 128) (encode-coding-char char coding)))
1f70b06d 528 (setq encoding-msg
c6fcc518
KH
529 (if encoded
530 (format "(0%o, %d, 0x%x, ext %s)"
531 char char char
532 (if (and (not detail)
533 (> (length encoded) 1))
534 "..."
535 (concat
536 (encoded-string-description encoded coding)
537 (if (cmpcharp char) "..." ""))))
1f70b06d 538 (format "(0%o, %d, 0x%x)" char char char)))
e5e89e48 539 (if detail
1f70b06d 540 ;; We show the detailed information of CHAR.
c6fcc518
KH
541 (let ((internal
542 (if (cmpcharp char)
543 ;; For a composite character, we show the
544 ;; components only.
545 (concat "(composed \""
546 (decompose-composite-char char)
547 "\")")
548 (split-char char))))
549 (message "Char: %s %s %s"
e5e89e48
RS
550 (if (< char 256)
551 (single-key-description char)
552 (char-to-string char))
c6fcc518 553 encoding-msg internal))
e5e89e48
RS
554 (if (or (/= beg 1) (/= end (1+ total)))
555 (message "Char: %s %s point=%d of %d(%d%%) <%d - %d> column %d %s"
556 (if (< char 256)
557 (single-key-description char)
558 (char-to-string char))
559 encoding-msg pos total percent beg end col hscroll)
560 (message "Char: %s %s point=%d of %d(%d%%) column %d %s"
e5a902cf
KH
561 (if (< char 256)
562 (single-key-description char)
563 (char-to-string char))
e5e89e48 564 encoding-msg pos total percent col hscroll)))))))
2076c87c
JB
565
566(defun fundamental-mode ()
567 "Major mode not specialized for anything in particular.
568Other major modes are defined by comparison with this one."
569 (interactive)
570 (kill-all-local-variables))
571
4578d35d 572(defvar read-expression-map (cons 'keymap minibuffer-local-map)
854c16c5
RS
573 "Minibuffer keymap used for reading Lisp expressions.")
574(define-key read-expression-map "\M-\t" 'lisp-complete-symbol)
575
8570b0ca
RM
576(defvar read-expression-history nil)
577
578;; We define this, rather than making `eval' interactive,
2076c87c 579;; for the sake of completion of names like eval-region, eval-current-buffer.
ecb7ad00
RS
580(defun eval-expression (eval-expression-arg
581 &optional eval-expression-insert-value)
2076c87c 582 "Evaluate EXPRESSION and print value in minibuffer.
eb57c304 583Value is also consed on to front of the variable `values'."
adca5fa6 584 (interactive
b387ef9a
RS
585 (list (read-from-minibuffer "Eval: "
586 nil read-expression-map t
ecb7ad00
RS
587 'read-expression-history)
588 current-prefix-arg))
bc43b8e8 589 (setq values (cons (eval eval-expression-arg) values))
ecb7ad00
RS
590 (prin1 (car values)
591 (if eval-expression-insert-value (current-buffer) t)))
2076c87c
JB
592
593(defun edit-and-eval-command (prompt command)
594 "Prompting with PROMPT, let user edit COMMAND and eval result.
595COMMAND is a Lisp expression. Let user edit that expression in
596the minibuffer, then read and evaluate the result."
b387ef9a
RS
597 (let ((command (read-from-minibuffer prompt
598 (prin1-to-string command)
599 read-expression-map t
600 '(command-history . 1))))
5d6c83ae 601 ;; If command was added to command-history as a string,
1f238ac2 602 ;; get rid of that. We want only evaluable expressions there.
5d6c83ae
KH
603 (if (stringp (car command-history))
604 (setq command-history (cdr command-history)))
605
606 ;; If command to be redone does not match front of history,
607 ;; add it to the history.
608 (or (equal command (car command-history))
609 (setq command-history (cons command command-history)))
2076c87c
JB
610 (eval command)))
611
ebb61177 612(defun repeat-complex-command (arg)
2076c87c
JB
613 "Edit and re-evaluate last complex command, or ARGth from last.
614A complex command is one which used the minibuffer.
615The command is placed in the minibuffer as a Lisp form for editing.
616The result is executed, repeating the command as changed.
617If the command has been changed or is not the most recent previous command
618it is added to the front of the command history.
eb6e9899
RS
619You can use the minibuffer history commands \\<minibuffer-local-map>\\[next-history-element] and \\[previous-history-element]
620to get different commands to edit and resubmit."
2076c87c 621 (interactive "p")
ba343182 622 (let ((elt (nth (1- arg) command-history))
2076c87c
JB
623 newcmd)
624 (if elt
854c16c5 625 (progn
eab22e27 626 (setq newcmd
74ae5fab
RS
627 (let ((print-level nil)
628 (minibuffer-history-position arg)
99ea24de 629 (minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
7908d27c
RS
630 (read-from-minibuffer
631 "Redo: " (prin1-to-string elt) read-expression-map t
632 (cons 'command-history arg))))
eab22e27 633
db16f109 634 ;; If command was added to command-history as a string,
1f238ac2 635 ;; get rid of that. We want only evaluable expressions there.
db16f109
RS
636 (if (stringp (car command-history))
637 (setq command-history (cdr command-history)))
638
639 ;; If command to be redone does not match front of history,
640 ;; add it to the history.
641 (or (equal newcmd (car command-history))
642 (setq command-history (cons newcmd command-history)))
2076c87c
JB
643 (eval newcmd))
644 (ding))))
e91f80c4 645\f
854c16c5
RS
646(defvar minibuffer-history nil
647 "Default minibuffer history list.
648This is used for all minibuffer input
649except when an alternate history list is specified.")
650(defvar minibuffer-history-sexp-flag nil
c2d4b6d9 651 "Non-nil when doing history operations on `command-history'.
854c16c5 652More generally, indicates that the history list being acted on
99ea24de
KH
653contains expressions rather than strings.
654It is only valid if its value equals the current minibuffer depth,
655to handle recursive uses of the minibuffer.")
e91f80c4
RS
656(setq minibuffer-history-variable 'minibuffer-history)
657(setq minibuffer-history-position nil)
854c16c5 658(defvar minibuffer-history-search-history nil)
e91f80c4 659
29929437 660(mapcar
d0678801
RM
661 (lambda (key-and-command)
662 (mapcar
663 (lambda (keymap-and-completionp)
664 ;; Arg is (KEYMAP-SYMBOL . COMPLETION-MAP-P).
665 ;; If the cdr of KEY-AND-COMMAND (the command) is a cons,
666 ;; its car is used if COMPLETION-MAP-P is nil, its cdr if it is t.
667 (define-key (symbol-value (car keymap-and-completionp))
668 (car key-and-command)
669 (let ((command (cdr key-and-command)))
670 (if (consp command)
b5e6f936
RM
671 ;; (and ... nil) => ... turns back on the completion-oriented
672 ;; history commands which rms turned off since they seem to
673 ;; do things he doesn't like.
674 (if (and (cdr keymap-and-completionp) nil) ;XXX turned off
d81362b0 675 (progn (error "EMACS BUG!") (cdr command))
d0678801
RM
676 (car command))
677 command))))
678 '((minibuffer-local-map . nil)
679 (minibuffer-local-ns-map . nil)
680 (minibuffer-local-completion-map . t)
681 (minibuffer-local-must-match-map . t)
682 (read-expression-map . nil))))
d81362b0
RM
683 '(("\en" . (next-history-element . next-complete-history-element))
684 ([next] . (next-history-element . next-complete-history-element))
685 ("\ep" . (previous-history-element . previous-complete-history-element))
686 ([prior] . (previous-history-element . previous-complete-history-element))
29929437
JB
687 ("\er" . previous-matching-history-element)
688 ("\es" . next-matching-history-element)))
e91f80c4 689
93cee14b
RS
690(defvar minibuffer-text-before-history nil
691 "Text that was in this minibuffer before any history commands.
692This is nil if there have not yet been any history commands
693in this use of the minibuffer.")
694
695(add-hook 'minibuffer-setup-hook 'minibuffer-history-initialize)
696
697(defun minibuffer-history-initialize ()
698 (setq minibuffer-text-before-history nil))
699
6e30a99a
RS
700(defcustom minibuffer-history-case-insensitive-variables nil
701 "*Minibuffer history variables for which matching should ignore case.
702If a history variable is a member of this list, then the
703\\[previous-matching-history-element] and \\[next-matching-history-element]\
704 commands ignore case when searching it, regardless of `case-fold-search'."
705 :type '(repeat variable)
706 :group 'minibuffer)
707
e91f80c4 708(defun previous-matching-history-element (regexp n)
854c16c5
RS
709 "Find the previous history element that matches REGEXP.
710\(Previous history elements refer to earlier actions.)
711With prefix argument N, search for Nth previous match.
5c2010f0 712If N is negative, find the next or Nth next match.
6e30a99a
RS
713An uppercase letter in REGEXP makes the search case-sensitive.
714See also `minibuffer-history-case-insensitive-variables'."
854c16c5 715 (interactive
c1172a19 716 (let* ((enable-recursive-minibuffers t)
c1172a19
RS
717 (regexp (read-from-minibuffer "Previous element matching (regexp): "
718 nil
719 minibuffer-local-map
720 nil
721 'minibuffer-history-search-history)))
722 ;; Use the last regexp specified, by default, if input is empty.
723 (list (if (string= regexp "")
a8e96cea
KH
724 (if minibuffer-history-search-history
725 (car minibuffer-history-search-history)
726 (error "No previous history search regexp"))
c1172a19 727 regexp)
854c16c5 728 (prefix-numeric-value current-prefix-arg))))
93cee14b
RS
729 (if (and (zerop minibuffer-history-position)
730 (null minibuffer-text-before-history))
731 (setq minibuffer-text-before-history (buffer-string)))
e91f80c4 732 (let ((history (symbol-value minibuffer-history-variable))
5c2010f0
RS
733 (case-fold-search
734 (if (isearch-no-upper-case-p regexp t) ; assume isearch.el is dumped
6e30a99a
RS
735 ;; On some systems, ignore case for file names.
736 (if (memq minibuffer-history-variable
737 minibuffer-history-case-insensitive-variables)
738 t
739 ;; Respect the user's setting for case-fold-search:
740 case-fold-search)
5c2010f0 741 nil))
ccc58657 742 prevpos
e91f80c4
RS
743 (pos minibuffer-history-position))
744 (while (/= n 0)
745 (setq prevpos pos)
746 (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history)))
747 (if (= pos prevpos)
748 (error (if (= pos 1)
ccc58657
RS
749 "No later matching history item"
750 "No earlier matching history item")))
e91f80c4 751 (if (string-match regexp
99ea24de
KH
752 (if (eq minibuffer-history-sexp-flag
753 (minibuffer-depth))
7908d27c
RS
754 (let ((print-level nil))
755 (prin1-to-string (nth (1- pos) history)))
e91f80c4 756 (nth (1- pos) history)))
854c16c5 757 (setq n (+ n (if (< n 0) 1 -1)))))
e91f80c4
RS
758 (setq minibuffer-history-position pos)
759 (erase-buffer)
760 (let ((elt (nth (1- pos) history)))
99ea24de 761 (insert (if (eq minibuffer-history-sexp-flag (minibuffer-depth))
7908d27c
RS
762 (let ((print-level nil))
763 (prin1-to-string elt))
e91f80c4 764 elt)))
854c16c5
RS
765 (goto-char (point-min)))
766 (if (or (eq (car (car command-history)) 'previous-matching-history-element)
767 (eq (car (car command-history)) 'next-matching-history-element))
768 (setq command-history (cdr command-history))))
e91f80c4 769
e91f80c4 770(defun next-matching-history-element (regexp n)
854c16c5
RS
771 "Find the next history element that matches REGEXP.
772\(The next history element refers to a more recent action.)
773With prefix argument N, search for Nth next match.
5c2010f0
RS
774If N is negative, find the previous or Nth previous match.
775An uppercase letter in REGEXP makes the search case-sensitive."
854c16c5 776 (interactive
c1172a19 777 (let* ((enable-recursive-minibuffers t)
c1172a19
RS
778 (regexp (read-from-minibuffer "Next element matching (regexp): "
779 nil
780 minibuffer-local-map
781 nil
782 'minibuffer-history-search-history)))
783 ;; Use the last regexp specified, by default, if input is empty.
784 (list (if (string= regexp "")
785 (setcar minibuffer-history-search-history
786 (nth 1 minibuffer-history-search-history))
787 regexp)
854c16c5 788 (prefix-numeric-value current-prefix-arg))))
e91f80c4 789 (previous-matching-history-element regexp (- n)))
2076c87c 790
ebb61177
RS
791(defun next-history-element (n)
792 "Insert the next element of the minibuffer history into the minibuffer."
2076c87c 793 (interactive "p")
0818b15e 794 (or (zerop n)
93cee14b
RS
795 (let ((narg (- minibuffer-history-position n))
796 (minimum (if minibuffer-default -1 0))
797 elt)
798 (if (and (zerop minibuffer-history-position)
799 (null minibuffer-text-before-history))
800 (setq minibuffer-text-before-history (buffer-string)))
801 (if (< narg minimum)
81091543
RS
802 (if minibuffer-default
803 (error "End of history; no next item")
804 (error "End of history; no default available")))
93cee14b
RS
805 (if (> narg (length (symbol-value minibuffer-history-variable)))
806 (error "Beginning of history; no preceding item"))
807 (erase-buffer)
808 (setq minibuffer-history-position narg)
809 (cond ((= narg -1)
810 (setq elt minibuffer-default))
811 ((= narg 0)
54c548db 812 (setq elt (or minibuffer-text-before-history ""))
93cee14b
RS
813 (setq minibuffer-text-before-history nil))
814 (t (setq elt (nth (1- minibuffer-history-position)
815 (symbol-value minibuffer-history-variable)))))
816 (insert
99ea24de 817 (if (eq minibuffer-history-sexp-flag (minibuffer-depth))
93cee14b
RS
818 (let ((print-level nil))
819 (prin1-to-string elt))
820 elt))
821 (goto-char (point-min)))))
2076c87c 822
ebb61177 823(defun previous-history-element (n)
3ee3a076 824 "Inserts the previous element of the minibuffer history into the minibuffer."
2076c87c 825 (interactive "p")
2c5e21c1 826 (next-history-element (- n)))
d0678801
RM
827
828(defun next-complete-history-element (n)
1f6fcec3 829 "Get next element of history which is a completion of minibuffer contents."
d0678801 830 (interactive "p")
b5e6f936
RM
831 (let ((point-at-start (point)))
832 (next-matching-history-element
833 (concat "^" (regexp-quote (buffer-substring (point-min) (point)))) n)
834 ;; next-matching-history-element always puts us at (point-min).
835 ;; Move to the position we were at before changing the buffer contents.
836 ;; This is still sensical, because the text before point has not changed.
837 (goto-char point-at-start)))
d0678801
RM
838
839(defun previous-complete-history-element (n)
1f6fcec3
RS
840 "\
841Get previous element of history which is a completion of minibuffer contents."
d0678801
RM
842 (interactive "p")
843 (next-complete-history-element (- n)))
e91f80c4 844\f
2076c87c
JB
845(defun goto-line (arg)
846 "Goto line ARG, counting from line 1 at beginning of buffer."
847 (interactive "NGoto line: ")
5f1a943c 848 (setq arg (prefix-numeric-value arg))
2076c87c
JB
849 (save-restriction
850 (widen)
851 (goto-char 1)
852 (if (eq selective-display t)
853 (re-search-forward "[\n\C-m]" nil 'end (1- arg))
854 (forward-line (1- arg)))))
855
856;Put this on C-x u, so we can force that rather than C-_ into startup msg
e462e42f 857(defalias 'advertised-undo 'undo)
2076c87c
JB
858
859(defun undo (&optional arg)
860 "Undo some previous changes.
861Repeat this command to undo more changes.
65627aad
RS
862A numeric argument serves as a repeat count.
863
864Just C-u as argument requests selective undo,
865limited to changes within the current region.
866Likewise in Transient Mark mode when the mark is active."
867 (interactive "*P")
456c617c
RS
868 ;; If we don't get all the way thru, make last-command indicate that
869 ;; for the following command.
870 (setq this-command t)
b553cffa
RS
871 (let ((modified (buffer-modified-p))
872 (recent-save (recent-auto-save-p)))
71e40adf
JB
873 (or (eq (selected-window) (minibuffer-window))
874 (message "Undo!"))
2076c87c 875 (or (eq last-command 'undo)
65627aad
RS
876 (progn (if (or arg (and transient-mark-mode mark-active))
877 (undo-start (region-beginning) (region-end))
878 (undo-start))
2076c87c 879 (undo-more 1)))
65627aad 880 (undo-more (if arg (prefix-numeric-value arg) 1))
2512c9f0
RS
881 ;; Don't specify a position in the undo record for the undo command.
882 ;; Instead, undoing this should move point to where the change is.
883 (let ((tail buffer-undo-list)
884 done)
885 (while (and tail (not done) (not (null (car tail))))
886 (if (integerp (car tail))
887 (progn
888 (setq done t)
889 (setq buffer-undo-list (delq (car tail) buffer-undo-list))))
890 (setq tail (cdr tail))))
2076c87c 891 (and modified (not (buffer-modified-p))
456c617c
RS
892 (delete-auto-save-file-if-necessary recent-save)))
893 ;; If we do get all the way thru, make this-command indicate that.
894 (setq this-command 'undo))
2076c87c 895
278b0a58
RS
896(defvar pending-undo-list nil
897 "Within a run of consecutive undo commands, list remaining to be undone.")
898
52d1110d
RS
899(defvar undo-in-progress nil
900 "Non-nil while performing an undo.
901Some change-hooks test this variable to do something different.")
902
2076c87c
JB
903(defun undo-more (count)
904 "Undo back N undo-boundaries beyond what was already undone recently.
ff1fbe3e
RS
905Call `undo-start' to get ready to undo recent changes,
906then call `undo-more' one or more times to undo them."
2076c87c
JB
907 (or pending-undo-list
908 (error "No further undo information"))
52d1110d
RS
909 (let ((undo-in-progress t))
910 (setq pending-undo-list (primitive-undo count pending-undo-list))))
2076c87c 911
65627aad
RS
912;; Deep copy of a list
913(defun undo-copy-list (list)
914 "Make a copy of undo list LIST."
915 (mapcar 'undo-copy-list-1 list))
916
917(defun undo-copy-list-1 (elt)
918 (if (consp elt)
919 (cons (car elt) (undo-copy-list-1 (cdr elt)))
920 elt))
921
922(defun undo-start (&optional beg end)
923 "Set `pending-undo-list' to the front of the undo list.
924The next call to `undo-more' will undo the most recently made change.
925If BEG and END are specified, then only undo elements
926that apply to text between BEG and END are used; other undo elements
927are ignored. If BEG and END are nil, all undo elements are used."
928 (if (eq buffer-undo-list t)
929 (error "No undo information in this buffer"))
930 (setq pending-undo-list
931 (if (and beg end (not (= beg end)))
932 (undo-make-selective-list (min beg end) (max beg end))
933 buffer-undo-list)))
934
935(defvar undo-adjusted-markers)
936
937(defun undo-make-selective-list (start end)
938 "Return a list of undo elements for the region START to END.
939The elements come from `buffer-undo-list', but we keep only
940the elements inside this region, and discard those outside this region.
941If we find an element that crosses an edge of this region,
942we stop and ignore all further elements."
943 (let ((undo-list-copy (undo-copy-list buffer-undo-list))
944 (undo-list (list nil))
945 undo-adjusted-markers
946 some-rejected
947 undo-elt undo-elt temp-undo-list delta)
948 (while undo-list-copy
949 (setq undo-elt (car undo-list-copy))
950 (let ((keep-this
951 (cond ((and (consp undo-elt) (eq (car undo-elt) t))
952 ;; This is a "was unmodified" element.
953 ;; Keep it if we have kept everything thus far.
954 (not some-rejected))
955 (t
956 (undo-elt-in-region undo-elt start end)))))
957 (if keep-this
958 (progn
959 (setq end (+ end (cdr (undo-delta undo-elt))))
960 ;; Don't put two nils together in the list
961 (if (not (and (eq (car undo-list) nil)
962 (eq undo-elt nil)))
963 (setq undo-list (cons undo-elt undo-list))))
964 (if (undo-elt-crosses-region undo-elt start end)
965 (setq undo-list-copy nil)
966 (setq some-rejected t)
967 (setq temp-undo-list (cdr undo-list-copy))
968 (setq delta (undo-delta undo-elt))
969
970 (when (/= (cdr delta) 0)
971 (let ((position (car delta))
972 (offset (cdr delta)))
973
974 ;; Loop down the earlier events adjusting their buffer positions
975 ;; to reflect the fact that a change to the buffer isn't being
976 ;; undone. We only need to process those element types which
977 ;; undo-elt-in-region will return as being in the region since
978 ;; only those types can ever get into the output
979
980 (while temp-undo-list
981 (setq undo-elt (car temp-undo-list))
982 (cond ((integerp undo-elt)
983 (if (>= undo-elt position)
984 (setcar temp-undo-list (- undo-elt offset))))
985 ((atom undo-elt) nil)
986 ((stringp (car undo-elt))
987 ;; (TEXT . POSITION)
988 (let ((text-pos (abs (cdr undo-elt)))
989 (point-at-end (< (cdr undo-elt) 0 )))
990 (if (>= text-pos position)
991 (setcdr undo-elt (* (if point-at-end -1 1)
992 (- text-pos offset))))))
993 ((integerp (car undo-elt))
994 ;; (BEGIN . END)
995 (when (>= (car undo-elt) position)
996 (setcar undo-elt (- (car undo-elt) offset))
997 (setcdr undo-elt (- (cdr undo-elt) offset))))
998 ((null (car undo-elt))
999 ;; (nil PROPERTY VALUE BEG . END)
1000 (let ((tail (nthcdr 3 undo-elt)))
1001 (when (>= (car tail) position)
1002 (setcar tail (- (car tail) offset))
1003 (setcdr tail (- (cdr tail) offset))))))
1004 (setq temp-undo-list (cdr temp-undo-list))))))))
1005 (setq undo-list-copy (cdr undo-list-copy)))
1006 (nreverse undo-list)))
1007
1008(defun undo-elt-in-region (undo-elt start end)
1009 "Determine whether UNDO-ELT falls inside the region START ... END.
1010If it crosses the edge, we return nil."
1011 (cond ((integerp undo-elt)
1012 (and (>= undo-elt start)
1013 (< undo-elt end)))
1014 ((eq undo-elt nil)
1015 t)
1016 ((atom undo-elt)
1017 nil)
1018 ((stringp (car undo-elt))
1019 ;; (TEXT . POSITION)
1020 (and (>= (abs (cdr undo-elt)) start)
1021 (< (abs (cdr undo-elt)) end)))
1022 ((and (consp undo-elt) (markerp (car undo-elt)))
1023 ;; This is a marker-adjustment element (MARKER . ADJUSTMENT).
1024 ;; See if MARKER is inside the region.
1025 (let ((alist-elt (assq (car undo-elt) undo-adjusted-markers)))
1026 (unless alist-elt
1027 (setq alist-elt (cons (car undo-elt)
1028 (marker-position (car undo-elt))))
1029 (setq undo-adjusted-markers
1030 (cons alist-elt undo-adjusted-markers)))
1031 (and (cdr alist-elt)
1032 (>= (cdr alist-elt) start)
1033 (< (cdr alist-elt) end))))
1034 ((null (car undo-elt))
1035 ;; (nil PROPERTY VALUE BEG . END)
1036 (let ((tail (nthcdr 3 undo-elt)))
1037 (and (>= (car tail) start)
1038 (< (cdr tail) end))))
1039 ((integerp (car undo-elt))
1040 ;; (BEGIN . END)
1041 (and (>= (car undo-elt) start)
1042 (< (cdr undo-elt) end)))))
1043
1044(defun undo-elt-crosses-region (undo-elt start end)
1045 "Test whether UNDO-ELT crosses one edge of that region START ... END.
1046This assumes we have already decided that UNDO-ELT
1047is not *inside* the region START...END."
1048 (cond ((atom undo-elt) nil)
1049 ((null (car undo-elt))
1050 ;; (nil PROPERTY VALUE BEG . END)
1051 (let ((tail (nthcdr 3 undo-elt)))
1052 (not (or (< (car tail) end)
1053 (> (cdr tail) start)))))
1054 ((integerp (car undo-elt))
1055 ;; (BEGIN . END)
1056 (not (or (< (car undo-elt) end)
1057 (> (cdr undo-elt) start))))))
1058
1059;; Return the first affected buffer position and the delta for an undo element
1060;; delta is defined as the change in subsequent buffer positions if we *did*
1061;; the undo.
1062(defun undo-delta (undo-elt)
1063 (if (consp undo-elt)
1064 (cond ((stringp (car undo-elt))
1065 ;; (TEXT . POSITION)
1066 (cons (abs (cdr undo-elt)) (length (car undo-elt))))
1067 ((integerp (car undo-elt))
1068 ;; (BEGIN . END)
1069 (cons (car undo-elt) (- (car undo-elt) (cdr undo-elt))))
1070 (t
1071 '(0 . 0)))
1072 '(0 . 0)))
1073\f
009ef402
RS
1074(defvar shell-command-history nil
1075 "History list for some commands that read shell commands.")
1076
59fc41e5
RS
1077(defvar shell-command-switch "-c"
1078 "Switch used to have the shell execute its command line argument.")
1079
d0d74413 1080(defun shell-command (command &optional output-buffer)
2076c87c 1081 "Execute string COMMAND in inferior shell; display output, if any.
d382f610 1082
2076c87c 1083If COMMAND ends in ampersand, execute it asynchronously.
d382f610 1084The output appears in the buffer `*Async Shell Command*'.
bcad4985 1085That buffer is in shell mode.
d382f610 1086
bcad4985
KH
1087Otherwise, COMMAND is executed synchronously. The output appears in the
1088buffer `*Shell Command Output*'.
d382f610
RS
1089If the output is one line, it is displayed in the echo area *as well*,
1090but it is nonetheless available in buffer `*Shell Command Output*',
1091even though that buffer is not automatically displayed.
1092If there is no output, or if output is inserted in the current buffer,
1093then `*Shell Command Output*' is deleted.
d0d74413 1094
07f458c1
RS
1095To specify a coding system for converting non-ASCII characters
1096in the shell command output, use \\[universal-coding-system-argument]
1097before this command.
1098
1099Noninteractive callers can specify coding systems by binding
1100`coding-system-for-read' and `coding-system-for-write'.
1101
d0d74413
RS
1102The optional second argument OUTPUT-BUFFER, if non-nil,
1103says to put the output in some other buffer.
1104If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
1105If OUTPUT-BUFFER is not a buffer and not nil,
1106insert output in current buffer. (This cannot be done asynchronously.)
1107In either case, the output is inserted after point (leaving mark after it)."
aa00b92d
RS
1108 (interactive (list (read-from-minibuffer "Shell command: "
1109 nil nil nil 'shell-command-history)
1110 current-prefix-arg))
c7edd03c
KH
1111 ;; Look for a handler in case default-directory is a remote file name.
1112 (let ((handler
1113 (find-file-name-handler (directory-file-name default-directory)
1114 'shell-command)))
1115 (if handler
1116 (funcall handler 'shell-command command output-buffer)
1117 (if (and output-buffer
1118 (not (or (bufferp output-buffer) (stringp output-buffer))))
1119 (progn (barf-if-buffer-read-only)
1120 (push-mark)
1121 ;; We do not use -f for csh; we will not support broken use of
1122 ;; .cshrcs. Even the BSD csh manual says to use
1123 ;; "if ($?prompt) exit" before things which are not useful
1124 ;; non-interactively. Besides, if someone wants their other
1125 ;; aliases for shell commands then they can still have them.
1126 (call-process shell-file-name nil t nil
1127 shell-command-switch command)
1128 ;; This is like exchange-point-and-mark, but doesn't
1129 ;; activate the mark. It is cleaner to avoid activation,
1130 ;; even though the command loop would deactivate the mark
1131 ;; because we inserted text.
1132 (goto-char (prog1 (mark t)
1133 (set-marker (mark-marker) (point)
1134 (current-buffer)))))
1135 ;; Preserve the match data in case called from a program.
1136 (save-match-data
1137 (if (string-match "[ \t]*&[ \t]*$" command)
1138 ;; Command ending with ampersand means asynchronous.
1139 (let ((buffer (get-buffer-create
1140 (or output-buffer "*Async Shell Command*")))
1141 (directory default-directory)
1142 proc)
1143 ;; Remove the ampersand.
1144 (setq command (substring command 0 (match-beginning 0)))
1145 ;; If will kill a process, query first.
1146 (setq proc (get-buffer-process buffer))
1147 (if proc
1148 (if (yes-or-no-p "A command is running. Kill it? ")
1149 (kill-process proc)
1150 (error "Shell command in progress")))
1151 (save-excursion
1152 (set-buffer buffer)
1153 (setq buffer-read-only nil)
1154 (erase-buffer)
1155 (display-buffer buffer)
1156 (setq default-directory directory)
1157 (setq proc (start-process "Shell" buffer shell-file-name
1158 shell-command-switch command))
1159 (setq mode-line-process '(":%s"))
1160 (require 'shell) (shell-mode)
1161 (set-process-sentinel proc 'shell-command-sentinel)
1162 ))
f2b3cdc3 1163 (shell-command-on-region (point) (point) command output-buffer)
c7edd03c 1164 ))))))
65627aad 1165\f
2076c87c
JB
1166;; We have a sentinel to prevent insertion of a termination message
1167;; in the buffer itself.
1168(defun shell-command-sentinel (process signal)
bcad4985
KH
1169 (if (memq (process-status process) '(exit signal))
1170 (message "%s: %s."
1171 (car (cdr (cdr (process-command process))))
1172 (substring signal 0 -1))))
2076c87c 1173
7fd47839
RS
1174(defvar shell-command-on-region-default-error-buffer nil
1175 "*Name of buffer that `shell-command-on-region' uses for stderr.
1176This buffer is used when `shell-command-on-region' is run interactively.
1177A nil value for this variable means that output to stderr and stdout
1178will be intermixed in the output stream.")
1179
d0d74413 1180(defun shell-command-on-region (start end command
cce1c318
RS
1181 &optional output-buffer replace
1182 error-buffer)
2076c87c
JB
1183 "Execute string COMMAND in inferior shell with region as input.
1184Normally display output (if any) in temp buffer `*Shell Command Output*';
a0184aeb
DL
1185Prefix arg means replace the region with it. Return the exit code of
1186COMMAND.
56c0450e 1187
07f458c1
RS
1188To specify a coding system for converting non-ASCII characters
1189in the input and output to the shell command, use \\[universal-coding-system-argument]
1190before this command. By default, the input (from the current buffer)
1191is encoded in the same coding system that will be used to save the file,
1192`buffer-file-coding-system'. If the output is going to replace the region,
1193then it is decoded from that same coding system.
1194
8923a211
RS
1195The noninteractive arguments are START, END, COMMAND, OUTPUT-BUFFER,
1196REPLACE, ERROR-BUFFER. Noninteractive callers can specify coding
1197systems by binding `coding-system-for-read' and
1198`coding-system-for-write'.
2076c87c
JB
1199
1200If the output is one line, it is displayed in the echo area,
1201but it is nonetheless available in buffer `*Shell Command Output*'
56c0450e 1202even though that buffer is not automatically displayed.
c42f586d 1203If there is no output, or if output is inserted in the current buffer,
56c0450e 1204then `*Shell Command Output*' is deleted.
d0d74413 1205
56c0450e
RS
1206If the optional fourth argument OUTPUT-BUFFER is non-nil,
1207that says to put the output in some other buffer.
d0d74413
RS
1208If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
1209If OUTPUT-BUFFER is not a buffer and not nil,
1210insert output in the current buffer.
cce1c318
RS
1211In either case, the output is inserted after point (leaving mark after it).
1212
8923a211
RS
1213If REPLACE, the optional fifth argument, is non-nil, that means insert
1214the output in place of text from START to END, putting point and mark
1215around it.
1216
b735c991 1217If optional sixth argument ERROR-BUFFER is non-nil, it is a buffer
cce1c318 1218or buffer name to which to direct the command's standard error output.
7fd47839
RS
1219If it is nil, error output is mingled with regular output.
1220In an interactive call, the variable
1221`shell-command-on-region-default-error-buffer' specifies the value
1222of ERROR-BUFFER."
cae49185
RS
1223 (interactive (let ((string
1224 ;; Do this before calling region-beginning
1225 ;; and region-end, in case subprocess output
1226 ;; relocates them while we are in the minibuffer.
1227 (read-from-minibuffer "Shell command on region: "
1228 nil nil nil
1229 'shell-command-history)))
2b03c506
RS
1230 ;; call-interactively recognizes region-beginning and
1231 ;; region-end specially, leaving them in the history.
1232 (list (region-beginning) (region-end)
cae49185
RS
1233 string
1234 current-prefix-arg
7fd47839
RS
1235 current-prefix-arg
1236 shell-command-on-region-default-error-buffer)))
cce1c318
RS
1237 (let ((error-file
1238 (if error-buffer
1239 (concat (file-name-directory temp-file-name-pattern)
1240 (make-temp-name "scor"))
a0184aeb
DL
1241 nil))
1242 exit-status)
7fd47839
RS
1243 (if (or replace
1244 (and output-buffer
1245 (not (or (bufferp output-buffer) (stringp output-buffer))))
1246 (equal (buffer-name (current-buffer)) "*Shell Command Output*"))
1247 ;; Replace specified region with output from command.
1248 (let ((swap (and replace (< start end))))
1249 ;; Don't muck with mark unless REPLACE says we should.
1250 (goto-char start)
1251 (and replace (push-mark))
a0184aeb
DL
1252 (setq exit-status
1253 (call-process-region start end shell-file-name t
1254 (if error-file
1255 (list t error-file)
1256 t)
1257 nil shell-command-switch command))
7fd47839
RS
1258 (let ((shell-buffer (get-buffer "*Shell Command Output*")))
1259 (and shell-buffer (not (eq shell-buffer (current-buffer)))
1260 (kill-buffer shell-buffer)))
1261 ;; Don't muck with mark unless REPLACE says we should.
1262 (and replace swap (exchange-point-and-mark)))
1263 ;; No prefix argument: put the output in a temp buffer,
1264 ;; replacing its entire contents.
1265 (let ((buffer (get-buffer-create
1266 (or output-buffer "*Shell Command Output*")))
a0184aeb 1267 (success nil))
7fd47839
RS
1268 (unwind-protect
1269 (if (eq buffer (current-buffer))
1270 ;; If the input is the same buffer as the output,
1271 ;; delete everything but the specified region,
1272 ;; then replace that region with the output.
1273 (progn (setq buffer-read-only nil)
1274 (delete-region (max start end) (point-max))
1275 (delete-region (point-min) (min start end))
1276 (setq exit-status
1277 (call-process-region (point-min) (point-max)
1278 shell-file-name t
1279 (if error-file
1280 (list t error-file)
1281 t)
a0184aeb
DL
1282 nil shell-command-switch
1283 command)))
1284 ;; Clear the output buffer, then run the command with
1285 ;; output there.
7fd47839
RS
1286 (save-excursion
1287 (set-buffer buffer)
1288 (setq buffer-read-only nil)
1289 (erase-buffer))
1290 (setq exit-status
1291 (call-process-region start end shell-file-name nil
1292 (if error-file
1293 (list buffer error-file)
1294 buffer)
a0184aeb
DL
1295 nil shell-command-switch command)))
1296 (setq success (zerop exit-status))
7fd47839
RS
1297 ;; Report the amount of output.
1298 (let ((lines (save-excursion
1299 (set-buffer buffer)
1300 (if (= (buffer-size) 0)
1301 0
1302 (count-lines (point-min) (point-max))))))
1303 (cond ((= lines 0)
1304 (if success
1305 (message "(Shell command %sed with no output)"
1306 (if (equal 0 exit-status)
1307 "succeed"
1308 "fail")))
1309 (kill-buffer buffer))
1310 ((and success (= lines 1))
1311 (message "%s"
1312 (save-excursion
1313 (set-buffer buffer)
1314 (goto-char (point-min))
1315 (buffer-substring (point)
1316 (progn (end-of-line) (point))))))
1317 (t
1318 (save-excursion
1319 (set-buffer buffer)
1320 (goto-char (point-min)))
1321 (display-buffer buffer)))))))
1322 (if (and error-file (file-exists-p error-file))
1323 (save-excursion
1324 (set-buffer (get-buffer-create error-buffer))
1325 ;; Do no formatting while reading error file, for fear of looping.
1326 (format-insert-file error-file nil)
a0184aeb
DL
1327 (delete-file error-file)))
1328 exit-status))
d589bd99
RS
1329
1330(defun shell-command-to-string (command)
1331 "Execute shell command COMMAND and return its output as a string."
1332 (with-output-to-string
17cc9013
RS
1333 (with-current-buffer
1334 standard-output
1335 (call-process shell-file-name nil t nil shell-command-switch command))))
2076c87c 1336\f
1b43f83f 1337(defvar universal-argument-map
69d4c3c4
KH
1338 (let ((map (make-sparse-keymap)))
1339 (define-key map [t] 'universal-argument-other-key)
b9ff190d 1340 (define-key map (vector meta-prefix-char t) 'universal-argument-other-key)
69d4c3c4
KH
1341 (define-key map [switch-frame] nil)
1342 (define-key map [?\C-u] 'universal-argument-more)
1343 (define-key map [?-] 'universal-argument-minus)
1344 (define-key map [?0] 'digit-argument)
1345 (define-key map [?1] 'digit-argument)
1346 (define-key map [?2] 'digit-argument)
1347 (define-key map [?3] 'digit-argument)
1348 (define-key map [?4] 'digit-argument)
1349 (define-key map [?5] 'digit-argument)
1350 (define-key map [?6] 'digit-argument)
1351 (define-key map [?7] 'digit-argument)
1352 (define-key map [?8] 'digit-argument)
1353 (define-key map [?9] 'digit-argument)
1354 map)
1355 "Keymap used while processing \\[universal-argument].")
1356
0de84e16
RS
1357(defvar universal-argument-num-events nil
1358 "Number of argument-specifying events read by `universal-argument'.
1359`universal-argument-other-key' uses this to discard those events
1360from (this-command-keys), and reread only the final command.")
1361
e8d1a377
KH
1362(defun universal-argument ()
1363 "Begin a numeric argument for the following command.
1364Digits or minus sign following \\[universal-argument] make up the numeric argument.
1365\\[universal-argument] following the digits or minus sign ends the argument.
1366\\[universal-argument] without digits or minus sign provides 4 as argument.
1367Repeating \\[universal-argument] without digits or minus sign
0565d307
RS
1368 multiplies the argument by 4 each time.
1369For some commands, just \\[universal-argument] by itself serves as a flag
a697fc62
RS
1370which is different in effect from any particular numeric argument.
1371These commands include \\[set-mark-command] and \\[start-kbd-macro]."
69d4c3c4
KH
1372 (interactive)
1373 (setq prefix-arg (list 4))
0de84e16 1374 (setq universal-argument-num-events (length (this-command-keys)))
69d4c3c4 1375 (setq overriding-terminal-local-map universal-argument-map))
e8d1a377 1376
69d4c3c4
KH
1377;; A subsequent C-u means to multiply the factor by 4 if we've typed
1378;; nothing but C-u's; otherwise it means to terminate the prefix arg.
1379(defun universal-argument-more (arg)
e8d1a377 1380 (interactive "P")
69d4c3c4
KH
1381 (if (consp arg)
1382 (setq prefix-arg (list (* 4 (car arg))))
1cd24721
RS
1383 (if (eq arg '-)
1384 (setq prefix-arg (list -4))
1385 (setq prefix-arg arg)
1386 (setq overriding-terminal-local-map nil)))
0de84e16 1387 (setq universal-argument-num-events (length (this-command-keys))))
e8d1a377
KH
1388
1389(defun negative-argument (arg)
1390 "Begin a negative numeric argument for the next command.
1391\\[universal-argument] following digits or minus sign ends the argument."
1392 (interactive "P")
69d4c3c4
KH
1393 (cond ((integerp arg)
1394 (setq prefix-arg (- arg)))
1395 ((eq arg '-)
1396 (setq prefix-arg nil))
1397 (t
b9ff190d 1398 (setq prefix-arg '-)))
0de84e16 1399 (setq universal-argument-num-events (length (this-command-keys)))
b9ff190d 1400 (setq overriding-terminal-local-map universal-argument-map))
69d4c3c4
KH
1401
1402(defun digit-argument (arg)
1403 "Part of the numeric argument for the next command.
1404\\[universal-argument] following digits or minus sign ends the argument."
1405 (interactive "P")
1406 (let ((digit (- (logand last-command-char ?\177) ?0)))
1407 (cond ((integerp arg)
1408 (setq prefix-arg (+ (* arg 10)
1409 (if (< arg 0) (- digit) digit))))
1410 ((eq arg '-)
1411 ;; Treat -0 as just -, so that -01 will work.
1412 (setq prefix-arg (if (zerop digit) '- (- digit))))
1413 (t
b9ff190d 1414 (setq prefix-arg digit))))
0de84e16 1415 (setq universal-argument-num-events (length (this-command-keys)))
b9ff190d 1416 (setq overriding-terminal-local-map universal-argument-map))
69d4c3c4
KH
1417
1418;; For backward compatibility, minus with no modifiers is an ordinary
1419;; command if digits have already been entered.
1420(defun universal-argument-minus (arg)
1421 (interactive "P")
1422 (if (integerp arg)
1423 (universal-argument-other-key arg)
1424 (negative-argument arg)))
1425
1426;; Anything else terminates the argument and is left in the queue to be
1427;; executed as a command.
1428(defun universal-argument-other-key (arg)
1429 (interactive "P")
1430 (setq prefix-arg arg)
0de84e16
RS
1431 (let* ((key (this-command-keys))
1432 (keylist (listify-key-sequence key)))
1433 (setq unread-command-events
06697cdb
RS
1434 (append (nthcdr universal-argument-num-events keylist)
1435 unread-command-events)))
f0ef2555 1436 (reset-this-command-lengths)
69d4c3c4 1437 (setq overriding-terminal-local-map nil))
e8d1a377 1438\f
2076c87c
JB
1439(defun forward-to-indentation (arg)
1440 "Move forward ARG lines and position at first nonblank character."
1441 (interactive "p")
1442 (forward-line arg)
1443 (skip-chars-forward " \t"))
1444
1445(defun backward-to-indentation (arg)
1446 "Move backward ARG lines and position at first nonblank character."
1447 (interactive "p")
1448 (forward-line (- arg))
1449 (skip-chars-forward " \t"))
1450
69c1dd37
RS
1451(defcustom kill-whole-line nil
1452 "*If non-nil, `kill-line' with no arg at beg of line kills the whole line."
1453 :type 'boolean
1454 :group 'killing)
38ebcf29 1455
2076c87c 1456(defun kill-line (&optional arg)
dff7d67f 1457 "Kill the rest of the current line; if no nonblanks there, kill thru newline.
2076c87c
JB
1458With prefix argument, kill that many lines from point.
1459Negative arguments kill lines backward.
1460
1461When calling from a program, nil means \"no arg\",
dff7d67f
RS
1462a number counts as a prefix arg.
1463
85969cb1
RS
1464To kill a whole line, when point is not at the beginning, type \
1465\\[beginning-of-line] \\[kill-line] \\[kill-line].
1466
1467If `kill-whole-line' is non-nil, then this command kills the whole line
1468including its terminating newline, when used at the beginning of a line
1469with no argument. As a consequence, you can always kill a whole line
1470by typing \\[beginning-of-line] \\[kill-line]."
2076c87c
JB
1471 (interactive "P")
1472 (kill-region (point)
e6291fe1
RS
1473 ;; It is better to move point to the other end of the kill
1474 ;; before killing. That way, in a read-only buffer, point
1475 ;; moves across the text that is copied to the kill ring.
1476 ;; The choice has no effect on undo now that undo records
1477 ;; the value of point from before the command was run.
1478 (progn
2076c87c 1479 (if arg
53efb707 1480 (forward-visible-line (prefix-numeric-value arg))
2076c87c
JB
1481 (if (eobp)
1482 (signal 'end-of-buffer nil))
38ebcf29 1483 (if (or (looking-at "[ \t]*$") (and kill-whole-line (bolp)))
53efb707
RS
1484 (forward-visible-line 1)
1485 (end-of-visible-line)))
2076c87c 1486 (point))))
53efb707
RS
1487
1488(defun forward-visible-line (arg)
9e7a6b30
RS
1489 "Move forward by ARG lines, ignoring currently invisible newlines only.
1490If ARG is negative, move backward -ARG lines.
1491If ARG is zero, move to the beginning of the current line."
53efb707 1492 (condition-case nil
29df77ba
RS
1493 (if (> arg 0)
1494 (while (> arg 0)
1495 (or (zerop (forward-line 1))
1496 (signal 'end-of-buffer nil))
9e7a6b30
RS
1497 ;; If the following character is currently invisible,
1498 ;; skip all characters with that same `invisible' property value,
1499 ;; then find the next newline.
1500 (while (and (not (eobp))
1501 (let ((prop
1502 (get-char-property (point) 'invisible)))
1503 (if (eq buffer-invisibility-spec t)
1504 prop
1505 (or (memq prop buffer-invisibility-spec)
1506 (assq prop buffer-invisibility-spec)))))
d91462ce
RS
1507 (goto-char
1508 (if (get-text-property (point) 'invisible)
1509 (or (next-single-property-change (point) 'invisible)
1510 (point-max))
1511 (next-overlay-change (point))))
9e7a6b30
RS
1512 (or (zerop (forward-line 1))
1513 (signal 'end-of-buffer nil)))
1514 (setq arg (1- arg)))
29df77ba
RS
1515 (let ((first t))
1516 (while (or first (< arg 0))
1517 (if (zerop arg)
1518 (beginning-of-line)
1519 (or (zerop (forward-line -1))
1520 (signal 'beginning-of-buffer nil)))
1521 (while (and (not (bobp))
1522 (let ((prop
1523 (get-char-property (1- (point)) 'invisible)))
1524 (if (eq buffer-invisibility-spec t)
1525 prop
1526 (or (memq prop buffer-invisibility-spec)
1527 (assq prop buffer-invisibility-spec)))))
d91462ce
RS
1528 (goto-char
1529 (if (get-text-property (1- (point)) 'invisible)
1530 (or (previous-single-property-change (point) 'invisible)
1531 (point-min))
1532 (previous-overlay-change (point))))
29df77ba
RS
1533 (or (zerop (forward-line -1))
1534 (signal 'beginning-of-buffer nil)))
1535 (setq first nil)
1536 (setq arg (1+ arg)))))
53efb707
RS
1537 ((beginning-of-buffer end-of-buffer)
1538 nil)))
1539
1540(defun end-of-visible-line ()
1541 "Move to end of current visible line."
1542 (end-of-line)
1543 ;; If the following character is currently invisible,
1544 ;; skip all characters with that same `invisible' property value,
1545 ;; then find the next newline.
1546 (while (and (not (eobp))
1547 (let ((prop
1548 (get-char-property (point) 'invisible)))
1549 (if (eq buffer-invisibility-spec t)
1550 prop
1551 (or (memq prop buffer-invisibility-spec)
1552 (assq prop buffer-invisibility-spec)))))
1553 (if (get-text-property (point) 'invisible)
1554 (goto-char (next-single-property-change (point) 'invisible))
1555 (goto-char (next-overlay-change (point))))
53efb707 1556 (end-of-line)))
2076c87c 1557\f
70e14c01
JB
1558;;;; Window system cut and paste hooks.
1559
1560(defvar interprogram-cut-function nil
1561 "Function to call to make a killed region available to other programs.
1562
1563Most window systems provide some sort of facility for cutting and
9f112a3d
RS
1564pasting text between the windows of different programs.
1565This variable holds a function that Emacs calls whenever text
1566is put in the kill ring, to make the new kill available to other
70e14c01
JB
1567programs.
1568
9f112a3d
RS
1569The function takes one or two arguments.
1570The first argument, TEXT, is a string containing
1571the text which should be made available.
1572The second, PUSH, if non-nil means this is a \"new\" kill;
1573nil means appending to an \"old\" kill.")
70e14c01
JB
1574
1575(defvar interprogram-paste-function nil
1576 "Function to call to get text cut from other programs.
1577
1578Most window systems provide some sort of facility for cutting and
9f112a3d
RS
1579pasting text between the windows of different programs.
1580This variable holds a function that Emacs calls to obtain
70e14c01
JB
1581text that other programs have provided for pasting.
1582
1583The function should be called with no arguments. If the function
1584returns nil, then no other program has provided such text, and the top
1585of the Emacs kill ring should be used. If the function returns a
daa37602
JB
1586string, that string should be put in the kill ring as the latest kill.
1587
1588Note that the function should return a string only if a program other
1589than Emacs has provided a string for pasting; if Emacs provided the
1590most recent string, the function should return nil. If it is
1591difficult to tell whether Emacs or some other program provided the
1592current string, it is probably good enough to return nil if the string
1593is equal (according to `string=') to the last text Emacs provided.")
70e14c01
JB
1594
1595
1596\f
1597;;;; The kill ring data structure.
2076c87c
JB
1598
1599(defvar kill-ring nil
70e14c01
JB
1600 "List of killed text sequences.
1601Since the kill ring is supposed to interact nicely with cut-and-paste
1602facilities offered by window systems, use of this variable should
1603interact nicely with `interprogram-cut-function' and
1604`interprogram-paste-function'. The functions `kill-new',
1605`kill-append', and `current-kill' are supposed to implement this
1606interaction; you may want to use them instead of manipulating the kill
1607ring directly.")
2076c87c 1608
bffa4d92 1609(defcustom kill-ring-max 60
69c1dd37
RS
1610 "*Maximum length of kill ring before oldest elements are thrown away."
1611 :type 'integer
1612 :group 'killing)
2076c87c
JB
1613
1614(defvar kill-ring-yank-pointer nil
1615 "The tail of the kill ring whose car is the last thing yanked.")
1616
f914dc91 1617(defun kill-new (string &optional replace)
70e14c01
JB
1618 "Make STRING the latest kill in the kill ring.
1619Set the kill-ring-yank pointer to point to it.
f914dc91
KH
1620If `interprogram-cut-function' is non-nil, apply it to STRING.
1621Optional second argument REPLACE non-nil means that STRING will replace
1622the front of the kill ring, rather than being added to the list."
f1d01ba2
KH
1623 (and (fboundp 'menu-bar-update-yank-menu)
1624 (menu-bar-update-yank-menu string (and replace (car kill-ring))))
f914dc91
KH
1625 (if replace
1626 (setcar kill-ring string)
1627 (setq kill-ring (cons string kill-ring))
1628 (if (> (length kill-ring) kill-ring-max)
1629 (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)))
70e14c01
JB
1630 (setq kill-ring-yank-pointer kill-ring)
1631 (if interprogram-cut-function
657a33ab 1632 (funcall interprogram-cut-function string (not replace))))
70e14c01 1633
2076c87c 1634(defun kill-append (string before-p)
70e14c01
JB
1635 "Append STRING to the end of the latest kill in the kill ring.
1636If BEFORE-P is non-nil, prepend STRING to the kill.
88c1aa79 1637If `interprogram-cut-function' is set, pass the resulting kill to
70e14c01 1638it."
f914dc91
KH
1639 (kill-new (if before-p
1640 (concat string (car kill-ring))
1641 (concat (car kill-ring) string)) t))
70e14c01
JB
1642
1643(defun current-kill (n &optional do-not-move)
1644 "Rotate the yanking point by N places, and then return that kill.
1645If N is zero, `interprogram-paste-function' is set, and calling it
1646returns a string, then that string is added to the front of the
1647kill ring and returned as the latest kill.
1648If optional arg DO-NOT-MOVE is non-nil, then don't actually move the
1649yanking point; just return the Nth kill forward."
1650 (let ((interprogram-paste (and (= n 0)
1651 interprogram-paste-function
1652 (funcall interprogram-paste-function))))
1653 (if interprogram-paste
1654 (progn
1655 ;; Disable the interprogram cut function when we add the new
1656 ;; text to the kill ring, so Emacs doesn't try to own the
1657 ;; selection, with identical text.
1658 (let ((interprogram-cut-function nil))
1659 (kill-new interprogram-paste))
1660 interprogram-paste)
1661 (or kill-ring (error "Kill ring is empty"))
47096a67
PE
1662 (let ((ARGth-kill-element
1663 (nthcdr (mod (- n (length kill-ring-yank-pointer))
1664 (length kill-ring))
1665 kill-ring)))
70e14c01
JB
1666 (or do-not-move
1667 (setq kill-ring-yank-pointer ARGth-kill-element))
1668 (car ARGth-kill-element)))))
c88ab9ce 1669
c88ab9ce 1670
70e14c01
JB
1671\f
1672;;;; Commands for manipulating the kill ring.
c88ab9ce 1673
69c1dd37
RS
1674(defcustom kill-read-only-ok nil
1675 "*Non-nil means don't signal an error for killing read-only text."
1676 :type 'boolean
1677 :group 'killing)
e6291fe1 1678
3a5da8a8
RS
1679(put 'text-read-only 'error-conditions
1680 '(text-read-only buffer-read-only error))
1681(put 'text-read-only 'error-message "Text is read-only")
1682
2076c87c
JB
1683(defun kill-region (beg end)
1684 "Kill between point and mark.
1685The text is deleted but saved in the kill ring.
1686The command \\[yank] can retrieve it from there.
1687\(If you want to kill and then yank immediately, use \\[copy-region-as-kill].)
2aa7a8bf
JB
1688If the buffer is read-only, Emacs will beep and refrain from deleting
1689the text, but put the text in the kill ring anyway. This means that
1690you can use the killing commands to copy text from a read-only buffer.
2076c87c
JB
1691
1692This is the primitive for programs to kill text (as opposed to deleting it).
1693Supply two arguments, character numbers indicating the stretch of text
1694 to be killed.
1695Any command that calls this function is a \"kill command\".
1696If the previous command was also a kill command,
1697the text killed this time appends to the text killed last time
1698to make one entry in the kill ring."
2aa7a8bf 1699 (interactive "r")
ccd19b9f
KH
1700 (condition-case nil
1701 ;; Don't let the undo list be truncated before we can even access it.
1702 (let ((undo-strong-limit (+ (- (max beg end) (min beg end)) 100))
1703 (old-list buffer-undo-list)
1704 tail
1705 ;; If we can't rely on finding the killed text
1706 ;; in the undo list, save it now as a string.
1707 (string (if (or (eq buffer-undo-list t)
1708 (= beg end))
1709 (buffer-substring beg end))))
1710 (delete-region beg end)
1711 ;; Search back in buffer-undo-list for this string,
1712 ;; in case a change hook made property changes.
1713 (setq tail buffer-undo-list)
1714 (unless string
1715 (while (not (stringp (car (car tail))))
1716 (setq tail (cdr tail)))
1717 ;; If we did not already make the string to use,
1718 ;; use the same one that undo made for us.
1719 (setq string (car (car tail))))
1720 ;; Add that string to the kill ring, one way or another.
1721 (if (eq last-command 'kill-region)
1722 (kill-append string (< end beg))
1723 (kill-new string))
1724 (setq this-command 'kill-region))
1725 ((buffer-read-only text-read-only)
1726 ;; The code above failed because the buffer, or some of the characters
1727 ;; in the region, are read-only.
1728 ;; We should beep, in case the user just isn't aware of this.
1729 ;; However, there's no harm in putting
1730 ;; the region's text in the kill ring, anyway.
1731 (copy-region-as-kill beg end)
cb3e1b4c
RS
1732 ;; Set this-command now, so it will be set even if we get an error.
1733 (setq this-command 'kill-region)
1734 ;; This should barf, if appropriate, and give us the correct error.
ccd19b9f
KH
1735 (if kill-read-only-ok
1736 (message "Read only text copied to kill ring")
ccd19b9f
KH
1737 ;; Signal an error if the buffer is read-only.
1738 (barf-if-buffer-read-only)
1739 ;; If the buffer isn't read-only, the text is.
1740 (signal 'text-read-only (list (current-buffer)))))))
2076c87c 1741
a382890a
KH
1742;; copy-region-as-kill no longer sets this-command, because it's confusing
1743;; to get two copies of the text when the user accidentally types M-w and
1744;; then corrects it with the intended C-w.
2076c87c
JB
1745(defun copy-region-as-kill (beg end)
1746 "Save the region as if killed, but don't kill it.
0e264847 1747In Transient Mark mode, deactivate the mark.
46947372
JB
1748If `interprogram-cut-function' is non-nil, also save the text for a window
1749system cut and paste."
2076c87c
JB
1750 (interactive "r")
1751 (if (eq last-command 'kill-region)
1752 (kill-append (buffer-substring beg end) (< end beg))
70e14c01 1753 (kill-new (buffer-substring beg end)))
0e264847 1754 (if transient-mark-mode
5c7319b6 1755 (setq deactivate-mark t))
2076c87c
JB
1756 nil)
1757
1758(defun kill-ring-save (beg end)
0964e562 1759 "Save the region as if killed, but don't kill it.
0e264847 1760In Transient Mark mode, deactivate the mark.
0964e562 1761If `interprogram-cut-function' is non-nil, also save the text for a window
0e264847
RS
1762system cut and paste.
1763
1764This command is similar to `copy-region-as-kill', except that it gives
1765visual feedback indicating the extent of the region being copied."
2076c87c
JB
1766 (interactive "r")
1767 (copy-region-as-kill beg end)
3a801d0c 1768 (if (interactive-p)
66050f10
RS
1769 (let ((other-end (if (= (point) beg) end beg))
1770 (opoint (point))
1771 ;; Inhibit quitting so we can make a quit here
1772 ;; look like a C-g typed as a command.
1773 (inhibit-quit t))
1774 (if (pos-visible-in-window-p other-end (selected-window))
1775 (progn
1776 ;; Swap point and mark.
1777 (set-marker (mark-marker) (point) (current-buffer))
1778 (goto-char other-end)
1779 (sit-for 1)
1780 ;; Swap back.
1781 (set-marker (mark-marker) other-end (current-buffer))
1782 (goto-char opoint)
1783 ;; If user quit, deactivate the mark
1784 ;; as C-g would as a command.
e4e593ae 1785 (and quit-flag mark-active
fcadf1c7 1786 (deactivate-mark)))
66050f10
RS
1787 (let* ((killed-text (current-kill 0))
1788 (message-len (min (length killed-text) 40)))
1789 (if (= (point) beg)
1790 ;; Don't say "killed"; that is misleading.
1791 (message "Saved text until \"%s\""
1792 (substring killed-text (- message-len)))
1793 (message "Saved text from \"%s\""
1794 (substring killed-text 0 message-len))))))))
2076c87c
JB
1795
1796(defun append-next-kill ()
ff1fbe3e 1797 "Cause following command, if it kills, to append to previous kill."
2076c87c
JB
1798 (interactive)
1799 (if (interactive-p)
1800 (progn
1801 (setq this-command 'kill-region)
1802 (message "If the next command is a kill, it will append"))
1803 (setq last-command 'kill-region)))
1804
2076c87c 1805(defun yank-pop (arg)
ff1fbe3e
RS
1806 "Replace just-yanked stretch of killed text with a different stretch.
1807This command is allowed only immediately after a `yank' or a `yank-pop'.
2076c87c 1808At such a time, the region contains a stretch of reinserted
ff1fbe3e 1809previously-killed text. `yank-pop' deletes that text and inserts in its
2076c87c
JB
1810place a different stretch of killed text.
1811
1812With no argument, the previous kill is inserted.
ff1fbe3e
RS
1813With argument N, insert the Nth previous kill.
1814If N is negative, this is a more recent kill.
2076c87c
JB
1815
1816The sequence of kills wraps around, so that after the oldest one
1817comes the newest one."
1818 (interactive "*p")
1819 (if (not (eq last-command 'yank))
1820 (error "Previous command was not a yank"))
1821 (setq this-command 'yank)
3a5da8a8
RS
1822 (let ((inhibit-read-only t)
1823 (before (< (point) (mark t))))
9a1277dd 1824 (delete-region (point) (mark t))
fd0f4056 1825 (set-marker (mark-marker) (point) (current-buffer))
6cd829a8 1826 (let ((opoint (point)))
7ae13091 1827 (insert (current-kill arg))
6cd829a8
RS
1828 (let ((inhibit-read-only t))
1829 (remove-text-properties opoint (point) '(read-only nil))))
fd0f4056
RS
1830 (if before
1831 ;; This is like exchange-point-and-mark, but doesn't activate the mark.
1832 ;; It is cleaner to avoid activation, even though the command
1833 ;; loop would deactivate the mark because we inserted text.
1834 (goto-char (prog1 (mark t)
1835 (set-marker (mark-marker) (point) (current-buffer))))))
0964e562 1836 nil)
2076c87c
JB
1837
1838(defun yank (&optional arg)
1839 "Reinsert the last stretch of killed text.
1840More precisely, reinsert the stretch of killed text most recently
ff1fbe3e
RS
1841killed OR yanked. Put point at end, and set mark at beginning.
1842With just C-u as argument, same but put point at beginning (and mark at end).
1843With argument N, reinsert the Nth most recently killed stretch of killed
2076c87c
JB
1844text.
1845See also the command \\[yank-pop]."
1846 (interactive "*P")
456c617c
RS
1847 ;; If we don't get all the way thru, make last-command indicate that
1848 ;; for the following command.
1849 (setq this-command t)
2076c87c 1850 (push-mark (point))
6cd829a8 1851 (let ((opoint (point)))
7ae13091
RS
1852 (insert (current-kill (cond
1853 ((listp arg) 0)
1854 ((eq arg '-) -1)
1855 (t (1- arg)))))
6cd829a8
RS
1856 (let ((inhibit-read-only t))
1857 (remove-text-properties opoint (point) '(read-only nil))))
2076c87c 1858 (if (consp arg)
fd0f4056
RS
1859 ;; This is like exchange-point-and-mark, but doesn't activate the mark.
1860 ;; It is cleaner to avoid activation, even though the command
1861 ;; loop would deactivate the mark because we inserted text.
1862 (goto-char (prog1 (mark t)
1863 (set-marker (mark-marker) (point) (current-buffer)))))
456c617c
RS
1864 ;; If we do get all the way thru, make this-command indicate that.
1865 (setq this-command 'yank)
0964e562 1866 nil)
70e14c01
JB
1867
1868(defun rotate-yank-pointer (arg)
1869 "Rotate the yanking point in the kill ring.
1870With argument, rotate that many kills forward (or backward, if negative)."
1871 (interactive "p")
1872 (current-kill arg))
1873
2076c87c
JB
1874\f
1875(defun insert-buffer (buffer)
1876 "Insert after point the contents of BUFFER.
1877Puts mark after the inserted text.
1878BUFFER may be a buffer or a buffer name."
c3d4f949 1879 (interactive
a3e7c391
FP
1880 (list
1881 (progn
1882 (barf-if-buffer-read-only)
1883 (read-buffer "Insert buffer: "
1884 (if (eq (selected-window) (next-window (selected-window)))
1885 (other-buffer (current-buffer))
1886 (window-buffer (next-window (selected-window))))
1887 t))))
2076c87c
JB
1888 (or (bufferp buffer)
1889 (setq buffer (get-buffer buffer)))
1890 (let (start end newmark)
1891 (save-excursion
1892 (save-excursion
1893 (set-buffer buffer)
1894 (setq start (point-min) end (point-max)))
1895 (insert-buffer-substring buffer start end)
1896 (setq newmark (point)))
1537a263
JB
1897 (push-mark newmark))
1898 nil)
2076c87c
JB
1899
1900(defun append-to-buffer (buffer start end)
1901 "Append to specified buffer the text of the region.
1902It is inserted into that buffer before its point.
1903
1904When calling from a program, give three arguments:
1905BUFFER (or buffer name), START and END.
1906START and END specify the portion of the current buffer to be copied."
70e14c01 1907 (interactive
5d771766 1908 (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) t))
23efee2c 1909 (region-beginning) (region-end)))
2076c87c
JB
1910 (let ((oldbuf (current-buffer)))
1911 (save-excursion
1912 (set-buffer (get-buffer-create buffer))
1913 (insert-buffer-substring oldbuf start end))))
1914
1915(defun prepend-to-buffer (buffer start end)
1916 "Prepend to specified buffer the text of the region.
1917It is inserted into that buffer after its point.
1918
1919When calling from a program, give three arguments:
1920BUFFER (or buffer name), START and END.
1921START and END specify the portion of the current buffer to be copied."
1922 (interactive "BPrepend to buffer: \nr")
1923 (let ((oldbuf (current-buffer)))
1924 (save-excursion
1925 (set-buffer (get-buffer-create buffer))
1926 (save-excursion
1927 (insert-buffer-substring oldbuf start end)))))
1928
1929(defun copy-to-buffer (buffer start end)
1930 "Copy to specified buffer the text of the region.
1931It is inserted into that buffer, replacing existing text there.
1932
1933When calling from a program, give three arguments:
1934BUFFER (or buffer name), START and END.
1935START and END specify the portion of the current buffer to be copied."
1936 (interactive "BCopy to buffer: \nr")
1937 (let ((oldbuf (current-buffer)))
1938 (save-excursion
1939 (set-buffer (get-buffer-create buffer))
1940 (erase-buffer)
1941 (save-excursion
1942 (insert-buffer-substring oldbuf start end)))))
1943\f
62d1c1fc
RM
1944(put 'mark-inactive 'error-conditions '(mark-inactive error))
1945(put 'mark-inactive 'error-message "The mark is not active now")
1946
af39530e 1947(defun mark (&optional force)
c7c8b31e 1948 "Return this buffer's mark value as integer; error if mark inactive.
af39530e 1949If optional argument FORCE is non-nil, access the mark value
c7c8b31e
RS
1950even if the mark is not currently active, and return nil
1951if there is no mark at all.
af39530e 1952
2076c87c
JB
1953If you are using this in an editing command, you are most likely making
1954a mistake; see the documentation of `set-mark'."
0e3a7b14 1955 (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive)
af39530e 1956 (marker-position (mark-marker))
62d1c1fc 1957 (signal 'mark-inactive nil)))
2076c87c 1958
19d35374
RM
1959;; Many places set mark-active directly, and several of them failed to also
1960;; run deactivate-mark-hook. This shorthand should simplify.
1961(defsubst deactivate-mark ()
1962 "Deactivate the mark by setting `mark-active' to nil.
fcadf1c7 1963\(That makes a difference only in Transient Mark mode.)
19d35374 1964Also runs the hook `deactivate-mark-hook'."
a4b9d3da
RS
1965 (if transient-mark-mode
1966 (progn
1967 (setq mark-active nil)
1968 (run-hooks 'deactivate-mark-hook))))
19d35374 1969
2076c87c
JB
1970(defun set-mark (pos)
1971 "Set this buffer's mark to POS. Don't use this function!
1972That is to say, don't use this function unless you want
1973the user to see that the mark has moved, and you want the previous
1974mark position to be lost.
1975
1976Normally, when a new mark is set, the old one should go on the stack.
1977This is why most applications should use push-mark, not set-mark.
1978
ff1fbe3e 1979Novice Emacs Lisp programmers often try to use the mark for the wrong
2076c87c
JB
1980purposes. The mark saves a location for the user's convenience.
1981Most editing commands should not alter the mark.
1982To remember a location for internal use in the Lisp program,
1983store it in a Lisp variable. Example:
1984
1985 (let ((beg (point))) (forward-line 1) (delete-region beg (point)))."
1986
fcadf1c7
RS
1987 (if pos
1988 (progn
1989 (setq mark-active t)
1990 (run-hooks 'activate-mark-hook)
1991 (set-marker (mark-marker) pos (current-buffer)))
24c22852
RS
1992 ;; Normally we never clear mark-active except in Transient Mark mode.
1993 ;; But when we actually clear out the mark value too,
1994 ;; we must clear mark-active in any mode.
1995 (setq mark-active nil)
1996 (run-hooks 'deactivate-mark-hook)
1997 (set-marker (mark-marker) nil)))
2076c87c
JB
1998
1999(defvar mark-ring nil
e55e2267 2000 "The list of former marks of the current buffer, most recent first.")
2076c87c 2001(make-variable-buffer-local 'mark-ring)
e55e2267 2002(put 'mark-ring 'permanent-local t)
2076c87c 2003
69c1dd37
RS
2004(defcustom mark-ring-max 16
2005 "*Maximum size of mark ring. Start discarding off end if gets this big."
2006 :type 'integer
2007 :group 'editing-basics)
2076c87c 2008
dc029f0b
RM
2009(defvar global-mark-ring nil
2010 "The list of saved global marks, most recent first.")
2011
69c1dd37 2012(defcustom global-mark-ring-max 16
dc029f0b 2013 "*Maximum size of global mark ring. \
69c1dd37
RS
2014Start discarding off end if gets this big."
2015 :type 'integer
2016 :group 'editing-basics)
dc029f0b 2017
2076c87c
JB
2018(defun set-mark-command (arg)
2019 "Set mark at where point is, or jump to mark.
dc029f0b
RM
2020With no prefix argument, set mark, push old mark position on local mark
2021ring, and push mark on global mark ring.
2022With argument, jump to mark, and pop a new position for mark off the ring
2023\(does not affect global mark ring\).
2076c87c 2024
ff1fbe3e 2025Novice Emacs Lisp programmers often try to use the mark for the wrong
2076c87c
JB
2026purposes. See the documentation of `set-mark' for more information."
2027 (interactive "P")
2028 (if (null arg)
9a1277dd 2029 (progn
fd0f4056 2030 (push-mark nil nil t))
af39530e 2031 (if (null (mark t))
2076c87c 2032 (error "No mark set in this buffer")
9a1277dd 2033 (goto-char (mark t))
2076c87c
JB
2034 (pop-mark))))
2035
fd0f4056 2036(defun push-mark (&optional location nomsg activate)
2076c87c 2037 "Set mark at LOCATION (point, by default) and push old mark on mark ring.
f1382a3d
RM
2038If the last global mark pushed was not in the current buffer,
2039also push LOCATION on the global mark ring.
fd0f4056 2040Display `Mark set' unless the optional second arg NOMSG is non-nil.
8cdc660f 2041In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil.
2076c87c 2042
ff1fbe3e 2043Novice Emacs Lisp programmers often try to use the mark for the wrong
9a1277dd
RS
2044purposes. See the documentation of `set-mark' for more information.
2045
2046In Transient Mark mode, this does not activate the mark."
af39530e 2047 (if (null (mark t))
2076c87c
JB
2048 nil
2049 (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring))
2050 (if (> (length mark-ring) mark-ring-max)
2051 (progn
2052 (move-marker (car (nthcdr mark-ring-max mark-ring)) nil)
2053 (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil))))
9a1277dd 2054 (set-marker (mark-marker) (or location (point)) (current-buffer))
dc029f0b 2055 ;; Now push the mark on the global mark ring.
f1382a3d 2056 (if (and global-mark-ring
e08d3f7c 2057 (eq (marker-buffer (car global-mark-ring)) (current-buffer)))
f1382a3d
RM
2058 ;; The last global mark pushed was in this same buffer.
2059 ;; Don't push another one.
2060 nil
2061 (setq global-mark-ring (cons (copy-marker (mark-marker)) global-mark-ring))
dc029f0b
RM
2062 (if (> (length global-mark-ring) global-mark-ring-max)
2063 (progn
2064 (move-marker (car (nthcdr global-mark-ring-max global-mark-ring))
2065 nil)
f1382a3d 2066 (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil))))
efcf38c7 2067 (or nomsg executing-kbd-macro (> (minibuffer-depth) 0)
2076c87c 2068 (message "Mark set"))
8cdc660f
RS
2069 (if (or activate (not transient-mark-mode))
2070 (set-mark (mark t)))
2076c87c
JB
2071 nil)
2072
2073(defun pop-mark ()
2074 "Pop off mark ring into the buffer's actual mark.
2075Does not set point. Does nothing if mark ring is empty."
2076 (if mark-ring
2077 (progn
2078 (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker)))))
9a1277dd 2079 (set-marker (mark-marker) (+ 0 (car mark-ring)) (current-buffer))
19d35374 2080 (deactivate-mark)
2076c87c 2081 (move-marker (car mark-ring) nil)
9a1277dd 2082 (if (null (mark t)) (ding))
2076c87c
JB
2083 (setq mark-ring (cdr mark-ring)))))
2084
e462e42f 2085(defalias 'exchange-dot-and-mark 'exchange-point-and-mark)
2076c87c 2086(defun exchange-point-and-mark ()
af39530e
RS
2087 "Put the mark where point is now, and point where the mark is now.
2088This command works even when the mark is not active,
2089and it reactivates the mark."
2076c87c 2090 (interactive nil)
af39530e 2091 (let ((omark (mark t)))
2076c87c
JB
2092 (if (null omark)
2093 (error "No mark set in this buffer"))
2094 (set-mark (point))
2095 (goto-char omark)
2096 nil))
e23c2c21 2097
22c3935a 2098(defun transient-mark-mode (arg)
e23c2c21 2099 "Toggle Transient Mark mode.
b411b5fa 2100With arg, turn Transient Mark mode on if arg is positive, off otherwise.
e23c2c21 2101
5dd1220d
RS
2102In Transient Mark mode, when the mark is active, the region is highlighted.
2103Changing the buffer \"deactivates\" the mark.
2104So do certain other operations that set the mark
2105but whose main purpose is something else--for example,
2106incremental search, \\[beginning-of-buffer], and \\[end-of-buffer]."
22c3935a 2107 (interactive "P")
e23c2c21
RS
2108 (setq transient-mark-mode
2109 (if (null arg)
2110 (not transient-mark-mode)
2c5d387c 2111 (> (prefix-numeric-value arg) 0)))
22c3935a
RS
2112 (if (interactive-p)
2113 (if transient-mark-mode
2114 (message "Transient Mark mode enabled")
2115 (message "Transient Mark mode disabled"))))
dc029f0b
RM
2116
2117(defun pop-global-mark ()
2118 "Pop off global mark ring and jump to the top location."
2119 (interactive)
52b6d445
RS
2120 ;; Pop entries which refer to non-existent buffers.
2121 (while (and global-mark-ring (not (marker-buffer (car global-mark-ring))))
2122 (setq global-mark-ring (cdr global-mark-ring)))
dc029f0b
RM
2123 (or global-mark-ring
2124 (error "No global mark set"))
2125 (let* ((marker (car global-mark-ring))
2126 (buffer (marker-buffer marker))
2127 (position (marker-position marker)))
34c31301
RS
2128 (setq global-mark-ring (nconc (cdr global-mark-ring)
2129 (list (car global-mark-ring))))
dc029f0b
RM
2130 (set-buffer buffer)
2131 (or (and (>= position (point-min))
2132 (<= position (point-max)))
2133 (widen))
2134 (goto-char position)
2135 (switch-to-buffer buffer)))
2076c87c 2136\f
69c1dd37
RS
2137(defcustom next-line-add-newlines t
2138 "*If non-nil, `next-line' inserts newline to avoid `end of buffer' error."
2139 :type 'boolean
2140 :group 'editing-basics)
38ebcf29 2141
2076c87c
JB
2142(defun next-line (arg)
2143 "Move cursor vertically down ARG lines.
2144If there is no character in the target line exactly under the current column,
2145the cursor is positioned after the character in that line which spans this
2146column, or at the end of the line if it is not long enough.
38ebcf29 2147If there is no line in the buffer after this one, behavior depends on the
1a2c3941
RS
2148value of `next-line-add-newlines'. If non-nil, it inserts a newline character
2149to create a line, and moves the cursor to that line. Otherwise it moves the
e47d38f6 2150cursor to the end of the buffer.
2076c87c
JB
2151
2152The command \\[set-goal-column] can be used to create
85969cb1
RS
2153a semipermanent goal column for this command.
2154Then instead of trying to move exactly vertically (or as close as possible),
2155this command moves to the specified goal column (or as close as possible).
2156The goal column is stored in the variable `goal-column', which is nil
2157when there is no goal column.
2076c87c
JB
2158
2159If you are thinking of using this in a Lisp program, consider
2160using `forward-line' instead. It is usually easier to use
2161and more reliable (no dependence on goal column, etc.)."
2162 (interactive "p")
028922cf
RS
2163 (if (and next-line-add-newlines (= arg 1))
2164 (let ((opoint (point)))
3534a809
RS
2165 (end-of-line)
2166 (if (eobp)
28191e20 2167 (newline 1)
028922cf
RS
2168 (goto-char opoint)
2169 (line-move arg)))
1a2c3941
RS
2170 (if (interactive-p)
2171 (condition-case nil
2172 (line-move arg)
2173 ((beginning-of-buffer end-of-buffer) (ding)))
2174 (line-move arg)))
2076c87c
JB
2175 nil)
2176
2177(defun previous-line (arg)
2178 "Move cursor vertically up ARG lines.
2179If there is no character in the target line exactly over the current column,
2180the cursor is positioned after the character in that line which spans this
2181column, or at the end of the line if it is not long enough.
2182
2183The command \\[set-goal-column] can be used to create
85969cb1
RS
2184a semipermanent goal column for this command.
2185Then instead of trying to move exactly vertically (or as close as possible),
2186this command moves to the specified goal column (or as close as possible).
2187The goal column is stored in the variable `goal-column', which is nil
2188when there is no goal column.
2076c87c
JB
2189
2190If you are thinking of using this in a Lisp program, consider using
c2e8a012 2191`forward-line' with a negative argument instead. It is usually easier
2076c87c
JB
2192to use and more reliable (no dependence on goal column, etc.)."
2193 (interactive "p")
1a2c3941
RS
2194 (if (interactive-p)
2195 (condition-case nil
2196 (line-move (- arg))
2197 ((beginning-of-buffer end-of-buffer) (ding)))
2198 (line-move (- arg)))
2076c87c
JB
2199 nil)
2200
69c1dd37 2201(defcustom track-eol nil
2076c87c
JB
2202 "*Non-nil means vertical motion starting at end of line keeps to ends of lines.
2203This means moving to the end of each line moved onto.
69c1dd37
RS
2204The beginning of a blank line does not count as the end of a line."
2205 :type 'boolean
2206 :group 'editing-basics)
2207
2208(defcustom goal-column nil
2209 "*Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil."
2210 :type '(choice integer
2211 (const :tag "None" nil))
2212 :group 'editing-basics)
912c6728 2213(make-variable-buffer-local 'goal-column)
2076c87c
JB
2214
2215(defvar temporary-goal-column 0
2216 "Current goal column for vertical motion.
2217It is the column where point was
2218at the start of current run of vertical motion commands.
c637ae6f 2219When the `track-eol' feature is doing its job, the value is 9999.")
2076c87c 2220
69c1dd37 2221(defcustom line-move-ignore-invisible nil
098fc1fb 2222 "*Non-nil means \\[next-line] and \\[previous-line] ignore invisible lines.
69c1dd37
RS
2223Outline mode sets this."
2224 :type 'boolean
2225 :group 'editing-basics)
098fc1fb 2226
8c745744
RS
2227;; This is the guts of next-line and previous-line.
2228;; Arg says how many lines to move.
2076c87c 2229(defun line-move (arg)
2596511d
RS
2230 ;; Don't run any point-motion hooks, and disregard intangibility,
2231 ;; for intermediate positions.
2232 (let ((inhibit-point-motion-hooks t)
2233 (opoint (point))
6c8499b9 2234 new line-end line-beg)
2596511d
RS
2235 (unwind-protect
2236 (progn
2237 (if (not (or (eq last-command 'next-line)
2238 (eq last-command 'previous-line)))
2239 (setq temporary-goal-column
2240 (if (and track-eol (eolp)
2241 ;; Don't count beg of empty line as end of line
2242 ;; unless we just did explicit end-of-line.
2243 (or (not (bolp)) (eq last-command 'end-of-line)))
2244 9999
2245 (current-column))))
2246 (if (and (not (integerp selective-display))
2247 (not line-move-ignore-invisible))
2248 ;; Use just newline characters.
2249 (or (if (> arg 0)
2250 (progn (if (> arg 1) (forward-line (1- arg)))
2251 ;; This way of moving forward ARG lines
2252 ;; verifies that we have a newline after the last one.
2253 ;; It doesn't get confused by intangible text.
2254 (end-of-line)
2255 (zerop (forward-line 1)))
2256 (and (zerop (forward-line arg))
2257 (bolp)))
2258 (signal (if (< arg 0)
2259 'beginning-of-buffer
2260 'end-of-buffer)
2261 nil))
2262 ;; Move by arg lines, but ignore invisible ones.
2263 (while (> arg 0)
2264 (end-of-line)
2265 (and (zerop (vertical-motion 1))
2266 (signal 'end-of-buffer nil))
2267 ;; If the following character is currently invisible,
2268 ;; skip all characters with that same `invisible' property value.
2269 (while (and (not (eobp))
2270 (let ((prop
2271 (get-char-property (point) 'invisible)))
2272 (if (eq buffer-invisibility-spec t)
2273 prop
2274 (or (memq prop buffer-invisibility-spec)
2275 (assq prop buffer-invisibility-spec)))))
2276 (if (get-text-property (point) 'invisible)
2277 (goto-char (next-single-property-change (point) 'invisible))
2278 (goto-char (next-overlay-change (point)))))
2279 (setq arg (1- arg)))
2280 (while (< arg 0)
2281 (beginning-of-line)
2282 (and (zerop (vertical-motion -1))
2283 (signal 'beginning-of-buffer nil))
2284 (while (and (not (bobp))
2285 (let ((prop
2286 (get-char-property (1- (point)) 'invisible)))
2287 (if (eq buffer-invisibility-spec t)
2288 prop
2289 (or (memq prop buffer-invisibility-spec)
2290 (assq prop buffer-invisibility-spec)))))
2291 (if (get-text-property (1- (point)) 'invisible)
2292 (goto-char (previous-single-property-change (point) 'invisible))
2293 (goto-char (previous-overlay-change (point)))))
2294 (setq arg (1+ arg))))
0565d307
RS
2295 (let ((buffer-invisibility-spec nil))
2296 (move-to-column (or goal-column temporary-goal-column))))
50be475d
RS
2297 (setq new (point))
2298 ;; If we are moving into some intangible text,
2299 ;; look for following text on the same line which isn't intangible
2300 ;; and move there.
6c8499b9
RS
2301 (setq line-end (save-excursion (end-of-line) (point)))
2302 (setq line-beg (save-excursion (beginning-of-line) (point)))
50be475d
RS
2303 (let ((after (and (< new (point-max))
2304 (get-char-property new 'intangible)))
2305 (before (and (> new (point-min))
6c8499b9
RS
2306 (get-char-property (1- new) 'intangible))))
2307 (when (and before (eq before after)
2308 (not (bolp)))
50be475d
RS
2309 (goto-char (point-min))
2310 (let ((inhibit-point-motion-hooks nil))
2311 (goto-char new))
2312 (if (<= new line-end)
2313 (setq new (point)))))
6c8499b9
RS
2314 ;; NEW is where we want to move to.
2315 ;; LINE-BEG and LINE-END are the beginning and end of the line.
2316 ;; Move there in just one step, from our starting position,
2317 ;; with intangibility and point-motion hooks enabled this time.
2596511d
RS
2318 (goto-char opoint)
2319 (setq inhibit-point-motion-hooks nil)
6c8499b9
RS
2320 (goto-char new)
2321 ;; If intangibility processing moved us to a different line,
2322 ;; readjust the horizontal position within the line we ended up at.
2323 (when (or (< (point) line-beg) (> (point) line-end))
2324 (setq new (point))
2325 (setq inhibit-point-motion-hooks t)
2326 (setq line-end (save-excursion (end-of-line) (point)))
2327 (beginning-of-line)
2328 (setq line-beg (point))
2329 (let ((buffer-invisibility-spec nil))
2330 (move-to-column (or goal-column temporary-goal-column)))
2331 (if (<= (point) line-end)
2332 (setq new (point)))
2333 (goto-char (point-min))
2334 (setq inhibit-point-motion-hooks nil)
2335 (goto-char new)
2336 )))
2596511d 2337 nil)
2076c87c 2338
d5ab2033
JB
2339;;; Many people have said they rarely use this feature, and often type
2340;;; it by accident. Maybe it shouldn't even be on a key.
2341(put 'set-goal-column 'disabled t)
2076c87c
JB
2342
2343(defun set-goal-column (arg)
2344 "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line].
2345Those commands will move to this position in the line moved to
2346rather than trying to keep the same horizontal position.
2347With a non-nil argument, clears out the goal column
912c6728
RS
2348so that \\[next-line] and \\[previous-line] resume vertical motion.
2349The goal column is stored in the variable `goal-column'."
2076c87c
JB
2350 (interactive "P")
2351 (if arg
2352 (progn
2353 (setq goal-column nil)
2354 (message "No goal column"))
2355 (setq goal-column (current-column))
2356 (message (substitute-command-keys
2357 "Goal column %d (use \\[set-goal-column] with an arg to unset it)")
2358 goal-column))
2359 nil)
2360\f
0d5bbbf7
ER
2361;;; Partial support for horizontal autoscrolling. Someday, this feature
2362;;; will be built into the C level and all the (hscroll-point-visible) calls
2363;;; will go away.
2364
69c1dd37 2365(defcustom hscroll-step 0
0d5bbbf7
ER
2366 "*The number of columns to try scrolling a window by when point moves out.
2367If that fails to bring point back on frame, point is centered instead.
69c1dd37
RS
2368If this is zero, point is always centered after it moves off frame."
2369 :type '(choice (const :tag "Alway Center" 0)
2370 (integer :format "%v" 1))
2371 :group 'editing-basics)
0d5bbbf7
ER
2372
2373(defun hscroll-point-visible ()
26c5bf8e
KH
2374 "Scrolls the selected window horizontally to make point visible."
2375 (save-excursion
2376 (set-buffer (window-buffer))
2377 (if (not (or truncate-lines
2378 (> (window-hscroll) 0)
2379 (and truncate-partial-width-windows
2380 (< (window-width) (frame-width)))))
2381 ;; Point is always visible when lines are wrapped.
2382 ()
2383 ;; If point is on the invisible part of the line before window-start,
2384 ;; then hscrolling can't bring it back, so reset window-start first.
2385 (and (< (point) (window-start))
2386 (let ((ws-bol (save-excursion
2387 (goto-char (window-start))
2388 (beginning-of-line)
2389 (point))))
2390 (and (>= (point) ws-bol)
2391 (set-window-start nil ws-bol))))
2392 (let* ((here (hscroll-window-column))
2393 (left (min (window-hscroll) 1))
2394 (right (1- (window-width))))
2395 ;; Allow for the truncation glyph, if we're not exactly at eol.
2396 (if (not (and (= here right)
2397 (= (following-char) ?\n)))
2398 (setq right (1- right)))
2399 (cond
2400 ;; If too far away, just recenter. But don't show too much
2401 ;; white space off the end of the line.
2402 ((or (< here (- left hscroll-step))
2403 (> here (+ right hscroll-step)))
2404 (let ((eol (save-excursion (end-of-line) (hscroll-window-column))))
2405 (scroll-left (min (- here (/ (window-width) 2))
2406 (- eol (window-width) -5)))))
2407 ;; Within range. Scroll by one step (or maybe not at all).
2408 ((< here left)
2409 (scroll-right hscroll-step))
2410 ((> here right)
2411 (scroll-left hscroll-step)))))))
2412
2413;; This function returns the window's idea of the display column of point,
2414;; assuming that the window is already known to be truncated rather than
2415;; wrapped, and that we've already handled the case where point is on the
2416;; part of the line before window-start. We ignore window-width; if point
2417;; is beyond the right margin, we want to know how far. The return value
2418;; includes the effects of window-hscroll, window-start, and the prompt
2419;; string in the minibuffer. It may be negative due to hscroll.
2420(defun hscroll-window-column ()
2421 (let* ((hscroll (window-hscroll))
2422 (startpos (save-excursion
2423 (beginning-of-line)
2424 (if (= (point) (save-excursion
2425 (goto-char (window-start))
2426 (beginning-of-line)
2427 (point)))
2428 (goto-char (window-start)))
2429 (point)))
2430 (hpos (+ (if (and (eq (selected-window) (minibuffer-window))
2431 (= 1 (window-start))
2432 (= startpos (point-min)))
2433 (minibuffer-prompt-width)
2434 0)
2435 (min 0 (- 1 hscroll))))
2436 val)
2437 (car (cdr (compute-motion startpos (cons hpos 0)
2438 (point) (cons 0 1)
2439 1000000 (cons hscroll 0) nil)))))
2440
0d5bbbf7 2441
dff7d67f
RS
2442;; rms: (1) The definitions of arrow keys should not simply restate
2443;; what keys they are. The arrow keys should run the ordinary commands.
2444;; (2) The arrow keys are just one of many common ways of moving point
2445;; within a line. Real horizontal autoscrolling would be a good feature,
2446;; but supporting it only for arrow keys is too incomplete to be desirable.
2447
2448;;;;; Make arrow keys do the right thing for improved terminal support
2449;;;;; When we implement true horizontal autoscrolling, right-arrow and
2450;;;;; left-arrow can lose the (if truncate-lines ...) clause and become
2451;;;;; aliases. These functions are bound to the corresponding keyboard
2452;;;;; events in loaddefs.el.
2453
2454;;(defun right-arrow (arg)
2455;; "Move right one character on the screen (with prefix ARG, that many chars).
2456;;Scroll right if needed to keep point horizontally onscreen."
2457;; (interactive "P")
2458;; (forward-char arg)
2459;; (hscroll-point-visible))
2460
2461;;(defun left-arrow (arg)
2462;; "Move left one character on the screen (with prefix ARG, that many chars).
2463;;Scroll left if needed to keep point horizontally onscreen."
2464;; (interactive "P")
2465;; (backward-char arg)
2466;; (hscroll-point-visible))
7492f5a6
RS
2467
2468(defun scroll-other-window-down (lines)
e47d38f6
RS
2469 "Scroll the \"other window\" down.
2470For more details, see the documentation for `scroll-other-window'."
7492f5a6
RS
2471 (interactive "P")
2472 (scroll-other-window
2473 ;; Just invert the argument's meaning.
2474 ;; We can do that without knowing which window it will be.
2475 (if (eq lines '-) nil
2476 (if (null lines) '-
2477 (- (prefix-numeric-value lines))))))
e47d38f6 2478(define-key esc-map [?\C-\S-v] 'scroll-other-window-down)
3aef9604
RS
2479
2480(defun beginning-of-buffer-other-window (arg)
2481 "Move point to the beginning of the buffer in the other window.
2482Leave mark at previous position.
2483With arg N, put point N/10 of the way from the true beginning."
2484 (interactive "P")
2485 (let ((orig-window (selected-window))
2486 (window (other-window-for-scrolling)))
2487 ;; We use unwind-protect rather than save-window-excursion
2488 ;; because the latter would preserve the things we want to change.
2489 (unwind-protect
2490 (progn
2491 (select-window window)
2492 ;; Set point and mark in that window's buffer.
2493 (beginning-of-buffer arg)
2494 ;; Set point accordingly.
2495 (recenter '(t)))
2496 (select-window orig-window))))
2497
2498(defun end-of-buffer-other-window (arg)
2499 "Move point to the end of the buffer in the other window.
2500Leave mark at previous position.
2501With arg N, put point N/10 of the way from the true end."
2502 (interactive "P")
2503 ;; See beginning-of-buffer-other-window for comments.
2504 (let ((orig-window (selected-window))
2505 (window (other-window-for-scrolling)))
2506 (unwind-protect
2507 (progn
2508 (select-window window)
4500ff36 2509 (end-of-buffer arg)
3aef9604
RS
2510 (recenter '(t)))
2511 (select-window orig-window))))
38ebcf29 2512\f
2076c87c
JB
2513(defun transpose-chars (arg)
2514 "Interchange characters around point, moving forward one character.
2515With prefix arg ARG, effect is to take character before point
2516and drag it forward past ARG other characters (backward if ARG negative).
2517If no argument and at end of line, the previous two chars are exchanged."
2518 (interactive "*P")
2519 (and (null arg) (eolp) (forward-char -1))
2520 (transpose-subr 'forward-char (prefix-numeric-value arg)))
2521
2522(defun transpose-words (arg)
2523 "Interchange words around point, leaving point at end of them.
2524With prefix arg ARG, effect is to take word before or around point
2525and drag it forward past ARG other words (backward if ARG negative).
2526If ARG is zero, the words around or after point and around or after mark
2527are interchanged."
2528 (interactive "*p")
2529 (transpose-subr 'forward-word arg))
2530
2531(defun transpose-sexps (arg)
2532 "Like \\[transpose-words] but applies to sexps.
2533Does not work on a sexp that point is in the middle of
2534if it is a list or string."
2535 (interactive "*p")
2536 (transpose-subr 'forward-sexp arg))
2537
2538(defun transpose-lines (arg)
2539 "Exchange current line and previous line, leaving point after both.
2540With argument ARG, takes previous line and moves it past ARG lines.
2541With argument 0, interchanges line point is in with line mark is in."
2542 (interactive "*p")
2543 (transpose-subr (function
2544 (lambda (arg)
d3f4ef3f 2545 (if (> arg 0)
2076c87c 2546 (progn
d3f4ef3f
AS
2547 ;; Move forward over ARG lines,
2548 ;; but create newlines if necessary.
2549 (setq arg (forward-line arg))
2550 (if (/= (preceding-char) ?\n)
2551 (setq arg (1+ arg)))
2552 (if (> arg 0)
2553 (newline arg)))
2076c87c
JB
2554 (forward-line arg))))
2555 arg))
2556
8b56e02d
RS
2557(defvar transpose-subr-start1)
2558(defvar transpose-subr-start2)
2559(defvar transpose-subr-end1)
2560(defvar transpose-subr-end2)
2561
2076c87c 2562(defun transpose-subr (mover arg)
8b56e02d
RS
2563 (let (transpose-subr-start1
2564 transpose-subr-end1
2565 transpose-subr-start2
2566 transpose-subr-end2)
2076c87c
JB
2567 (if (= arg 0)
2568 (progn
2569 (save-excursion
2570 (funcall mover 1)
8b56e02d 2571 (setq transpose-subr-end2 (point))
2076c87c 2572 (funcall mover -1)
8b56e02d 2573 (setq transpose-subr-start2 (point))
2076c87c
JB
2574 (goto-char (mark))
2575 (funcall mover 1)
8b56e02d 2576 (setq transpose-subr-end1 (point))
2076c87c 2577 (funcall mover -1)
8b56e02d 2578 (setq transpose-subr-start1 (point))
2076c87c 2579 (transpose-subr-1))
d3f4ef3f
AS
2580 (exchange-point-and-mark))
2581 (if (> arg 0)
2582 (progn
2583 (funcall mover -1)
8b56e02d 2584 (setq transpose-subr-start1 (point))
d3f4ef3f 2585 (funcall mover 1)
8b56e02d 2586 (setq transpose-subr-end1 (point))
d3f4ef3f 2587 (funcall mover arg)
8b56e02d 2588 (setq transpose-subr-end2 (point))
d3f4ef3f 2589 (funcall mover (- arg))
8b56e02d 2590 (setq transpose-subr-start2 (point))
d3f4ef3f 2591 (transpose-subr-1)
8b56e02d 2592 (goto-char transpose-subr-end2))
d3f4ef3f 2593 (funcall mover -1)
8b56e02d 2594 (setq transpose-subr-start2 (point))
d3f4ef3f 2595 (funcall mover 1)
8b56e02d 2596 (setq transpose-subr-end2 (point))
d3f4ef3f 2597 (funcall mover (1- arg))
8b56e02d 2598 (setq transpose-subr-start1 (point))
d3f4ef3f 2599 (funcall mover (- arg))
8b56e02d 2600 (setq transpose-subr-end1 (point))
d3f4ef3f 2601 (transpose-subr-1)))))
2076c87c
JB
2602
2603(defun transpose-subr-1 ()
8b56e02d
RS
2604 (if (> (min transpose-subr-end1 transpose-subr-end2)
2605 (max transpose-subr-start1 transpose-subr-start2))
2076c87c 2606 (error "Don't have two things to transpose"))
8b56e02d 2607 (let* ((word1 (buffer-substring transpose-subr-start1 transpose-subr-end1))
d5d99b80 2608 (len1 (length word1))
8b56e02d 2609 (word2 (buffer-substring transpose-subr-start2 transpose-subr-end2))
d5d99b80 2610 (len2 (length word2)))
8b56e02d
RS
2611 (delete-region transpose-subr-start2 transpose-subr-end2)
2612 (goto-char transpose-subr-start2)
2076c87c 2613 (insert word1)
8b56e02d
RS
2614 (goto-char (if (< transpose-subr-start1 transpose-subr-start2)
2615 transpose-subr-start1
2616 (+ transpose-subr-start1 (- len1 len2))))
d5d99b80 2617 (delete-region (point) (+ (point) len1))
2076c87c
JB
2618 (insert word2)))
2619\f
69c1dd37 2620(defcustom comment-column 32
2076c87c 2621 "*Column to indent right-margin comments to.
8a8fa723
JB
2622Setting this variable automatically makes it local to the current buffer.
2623Each mode establishes a different default value for this variable; you
69c1dd37
RS
2624can set the value for a particular mode using that mode's hook."
2625 :type 'integer
2626 :group 'fill-comments)
2076c87c
JB
2627(make-variable-buffer-local 'comment-column)
2628
69c1dd37
RS
2629(defcustom comment-start nil
2630 "*String to insert to start a new comment, or nil if no comment syntax."
2631 :type '(choice (const :tag "None" nil)
2632 string)
2633 :group 'fill-comments)
2076c87c 2634
69c1dd37 2635(defcustom comment-start-skip nil
2076c87c
JB
2636 "*Regexp to match the start of a comment plus everything up to its body.
2637If there are any \\(...\\) pairs, the comment delimiter text is held to begin
69c1dd37
RS
2638at the place matched by the close of the first pair."
2639 :type '(choice (const :tag "None" nil)
2640 regexp)
2641 :group 'fill-comments)
2076c87c 2642
69c1dd37 2643(defcustom comment-end ""
2076c87c 2644 "*String to insert to end a new comment.
69c1dd37
RS
2645Should be an empty string if comments are terminated by end-of-line."
2646 :type 'string
2647 :group 'fill-comments)
2076c87c 2648
1b43f83f 2649(defvar comment-indent-hook nil
ec9a76e3
JB
2650 "Obsolete variable for function to compute desired indentation for a comment.
2651This function is called with no args with point at the beginning of
2652the comment's starting delimiter.")
2653
1b43f83f 2654(defvar comment-indent-function
2076c87c
JB
2655 '(lambda () comment-column)
2656 "Function to compute desired indentation for a comment.
2657This function is called with no args with point at the beginning of
2658the comment's starting delimiter.")
2659
69c1dd37 2660(defcustom block-comment-start nil
534a0de5
RS
2661 "*String to insert to start a new comment on a line by itself.
2662If nil, use `comment-start' instead.
2663Note that the regular expression `comment-start-skip' should skip this string
69c1dd37
RS
2664as well as the `comment-start' string."
2665 :type '(choice (const :tag "Use comment-start" nil)
2666 string)
2667 :group 'fill-comments)
534a0de5 2668
69c1dd37 2669(defcustom block-comment-end nil
534a0de5
RS
2670 "*String to insert to end a new comment on a line by itself.
2671Should be an empty string if comments are terminated by end-of-line.
69c1dd37
RS
2672If nil, use `comment-end' instead."
2673 :type '(choice (const :tag "Use comment-end" nil)
2674 string)
2675 :group 'fill-comments)
534a0de5 2676
2076c87c
JB
2677(defun indent-for-comment ()
2678 "Indent this line's comment to comment column, or insert an empty comment."
2679 (interactive "*")
534a0de5
RS
2680 (let* ((empty (save-excursion (beginning-of-line)
2681 (looking-at "[ \t]*$")))
2682 (starter (or (and empty block-comment-start) comment-start))
2683 (ender (or (and empty block-comment-end) comment-end)))
d4a753f9
DL
2684 (cond
2685 ((null starter)
2686 (error "No comment syntax defined"))
2687 ((null comment-start-skip)
2688 (error "This mode doesn't define `comment-start-skip'"))
2689 (t (let* ((eolpos (save-excursion (end-of-line) (point)))
2690 cpos indent begpos)
2691 (beginning-of-line)
2692 (if (re-search-forward comment-start-skip eolpos 'move)
2693 (progn (setq cpos (point-marker))
2694 ;; Find the start of the comment delimiter.
2695 ;; If there were paren-pairs in comment-start-skip,
2696 ;; position at the end of the first pair.
2697 (if (match-end 1)
2698 (goto-char (match-end 1))
2699 ;; If comment-start-skip matched a string with
2700 ;; internal whitespace (not final whitespace) then
2701 ;; the delimiter start at the end of that
2702 ;; whitespace. Otherwise, it starts at the
2703 ;; beginning of what was matched.
2704 (skip-syntax-backward " " (match-beginning 0))
2705 (skip-syntax-backward "^ " (match-beginning 0)))))
2706 (setq begpos (point))
2707 ;; Compute desired indent.
2708 (if (= (current-column)
2709 (setq indent (if comment-indent-hook
2710 (funcall comment-indent-hook)
2711 (funcall comment-indent-function))))
2712 (goto-char begpos)
2713 ;; If that's different from current, change it.
2714 (skip-chars-backward " \t")
2715 (delete-region (point) begpos)
2716 (indent-to indent))
2717 ;; An existing comment?
2718 (if cpos
2719 (progn (goto-char cpos)
2720 (set-marker cpos nil))
2721 ;; No, insert one.
2722 (insert starter)
2723 (save-excursion
2724 (insert ender))))))))
2076c87c
JB
2725
2726(defun set-comment-column (arg)
2727 "Set the comment column based on point.
2728With no arg, set the comment column to the current column.
2729With just minus as arg, kill any comment on this line.
2730With any other arg, set comment column to indentation of the previous comment
2731 and then align or create a comment on this line at that column."
2732 (interactive "P")
2733 (if (eq arg '-)
2734 (kill-comment nil)
2735 (if arg
2736 (progn
2737 (save-excursion
2738 (beginning-of-line)
2739 (re-search-backward comment-start-skip)
2740 (beginning-of-line)
2741 (re-search-forward comment-start-skip)
2742 (goto-char (match-beginning 0))
2743 (setq comment-column (current-column))
2744 (message "Comment column set to %d" comment-column))
2745 (indent-for-comment))
2746 (setq comment-column (current-column))
2747 (message "Comment column set to %d" comment-column))))
2748
2749(defun kill-comment (arg)
2750 "Kill the comment on this line, if any.
2751With argument, kill comments on that many lines starting with this one."
2752 ;; this function loses in a lot of situations. it incorrectly recognises
2753 ;; comment delimiters sometimes (ergo, inside a string), doesn't work
2754 ;; with multi-line comments, can kill extra whitespace if comment wasn't
2755 ;; through end-of-line, et cetera.
2756 (interactive "P")
2757 (or comment-start-skip (error "No comment syntax defined"))
2758 (let ((count (prefix-numeric-value arg)) endc)
2759 (while (> count 0)
2760 (save-excursion
2761 (end-of-line)
2762 (setq endc (point))
2763 (beginning-of-line)
2764 (and (string< "" comment-end)
2765 (setq endc
2766 (progn
2767 (re-search-forward (regexp-quote comment-end) endc 'move)
2768 (skip-chars-forward " \t")
2769 (point))))
2770 (beginning-of-line)
2771 (if (re-search-forward comment-start-skip endc t)
2772 (progn
2773 (goto-char (match-beginning 0))
2774 (skip-chars-backward " \t")
2775 (kill-region (point) endc)
2776 ;; to catch comments a line beginnings
2777 (indent-according-to-mode))))
2778 (if arg (forward-line 1))
2779 (setq count (1- count)))))
2780
3fb7b588
KH
2781(defvar comment-padding 1
2782 "Number of spaces `comment-region' puts between comment chars and text.
2783
2784Extra spacing between the comment characters and the comment text
2785makes the comment easier to read. Default is 1. Nil means 0 and is
2786more efficient.")
2787
2076c87c 2788(defun comment-region (beg end &optional arg)
f28039bb
RS
2789 "Comment or uncomment each line in the region.
2790With just C-u prefix arg, uncomment each line in region.
2791Numeric prefix arg ARG means use ARG comment characters.
2076c87c
JB
2792If ARG is negative, delete that many comment characters instead.
2793Comments are terminated on each line, even for syntax in which newline does
2794not end the comment. Blank lines do not get comments."
2795 ;; if someone wants it to only put a comment-start at the beginning and
2796 ;; comment-end at the end then typing it, C-x C-x, closing it, C-x C-x
2797 ;; is easy enough. No option is made here for other than commenting
2798 ;; every line.
f28039bb 2799 (interactive "r\nP")
2076c87c
JB
2800 (or comment-start (error "No comment syntax is defined"))
2801 (if (> beg end) (let (mid) (setq mid beg beg end end mid)))
2802 (save-excursion
2803 (save-restriction
f28039bb 2804 (let ((cs comment-start) (ce comment-end)
4044f853
KH
2805 (cp (when comment-padding
2806 (make-string comment-padding ? )))
f28039bb 2807 numarg)
4044f853 2808 (if (consp arg) (setq numarg t)
f28039bb
RS
2809 (setq numarg (prefix-numeric-value arg))
2810 ;; For positive arg > 1, replicate the comment delims now,
2811 ;; then insert the replicated strings just once.
2812 (while (> numarg 1)
2813 (setq cs (concat cs comment-start)
2814 ce (concat ce comment-end))
2815 (setq numarg (1- numarg))))
2816 ;; Loop over all lines from BEG to END.
4044f853
KH
2817 (narrow-to-region beg end)
2818 (goto-char beg)
2819 (if (or (eq numarg t) (< numarg 0))
2820 (while (not (eobp))
7be272f4 2821 (let (found-comment)
f28039bb
RS
2822 ;; Delete comment start from beginning of line.
2823 (if (eq numarg t)
2824 (while (looking-at (regexp-quote cs))
7be272f4 2825 (setq found-comment t)
f28039bb
RS
2826 (delete-char (length cs)))
2827 (let ((count numarg))
2828 (while (and (> 1 (setq count (1+ count)))
2829 (looking-at (regexp-quote cs)))
7be272f4 2830 (setq found-comment t)
f28039bb 2831 (delete-char (length cs)))))
4044f853 2832 ;; Delete comment padding from beginning of line
7be272f4
RS
2833 (when (and found-comment comment-padding
2834 (looking-at (regexp-quote cp)))
2835 (delete-char comment-padding))
f28039bb 2836 ;; Delete comment end from end of line.
4044f853 2837 (if (string= "" ce)
f28039bb
RS
2838 nil
2839 (if (eq numarg t)
2840 (progn
2841 (end-of-line)
2842 ;; This is questionable if comment-end ends in
2843 ;; whitespace. That is pretty brain-damaged,
2844 ;; though.
5c8ddcfb
RS
2845 (while (progn (skip-chars-backward " \t")
2846 (and (>= (- (point) (point-min)) (length ce))
2847 (save-excursion
2848 (backward-char (length ce))
2849 (looking-at (regexp-quote ce)))))
f28039bb 2850 (delete-char (- (length ce)))))
ee095968
RS
2851 (let ((count numarg))
2852 (while (> 1 (setq count (1+ count)))
2853 (end-of-line)
2854 ;; this is questionable if comment-end ends in whitespace
2855 ;; that is pretty brain-damaged though
2856 (skip-chars-backward " \t")
e1f0a6d2
RS
2857 (if (>= (- (point) (point-min)) (length ce))
2858 (save-excursion
2859 (backward-char (length ce))
2860 (if (looking-at (regexp-quote ce))
2861 (delete-char (length ce)))))))))
4044f853
KH
2862 (forward-line 1)))
2863
2864 (when comment-padding
2865 (setq cs (concat cs cp)))
2866 (while (not (eobp))
f28039bb 2867 ;; Insert at beginning and at end.
4044f853
KH
2868 (if (looking-at "[ \t]*$") ()
2869 (insert cs)
2870 (if (string= "" ce) ()
2871 (end-of-line)
2872 (insert ce)))
2873 (search-forward "\n" nil 'move)))))))
2076c87c
JB
2874\f
2875(defun backward-word (arg)
2876 "Move backward until encountering the end of a word.
2877With argument, do this that many times.
ff1fbe3e 2878In programs, it is faster to call `forward-word' with negative arg."
9e50756b 2879 (interactive "p")
2076c87c
JB
2880 (forward-word (- arg)))
2881
2882(defun mark-word (arg)
2883 "Set mark arg words away from point."
2884 (interactive "p")
2885 (push-mark
2886 (save-excursion
2887 (forward-word arg)
fd0f4056
RS
2888 (point))
2889 nil t))
2076c87c
JB
2890
2891(defun kill-word (arg)
2892 "Kill characters forward until encountering the end of a word.
2893With argument, do this that many times."
2894 (interactive "p")
e6291fe1 2895 (kill-region (point) (progn (forward-word arg) (point))))
2076c87c
JB
2896
2897(defun backward-kill-word (arg)
2898 "Kill characters backward until encountering the end of a word.
2899With argument, do this that many times."
2900 (interactive "p")
2901 (kill-word (- arg)))
d7c64071 2902
1e8c5ac4
RS
2903(defun current-word (&optional strict)
2904 "Return the word point is on (or a nearby word) as a string.
2905If optional arg STRICT is non-nil, return nil unless point is within
2906or adjacent to a word."
d7c64071
ER
2907 (save-excursion
2908 (let ((oldpoint (point)) (start (point)) (end (point)))
2909 (skip-syntax-backward "w_") (setq start (point))
2910 (goto-char oldpoint)
2911 (skip-syntax-forward "w_") (setq end (point))
2912 (if (and (eq start oldpoint) (eq end oldpoint))
1e8c5ac4
RS
2913 ;; Point is neither within nor adjacent to a word.
2914 (and (not strict)
2915 (progn
2916 ;; Look for preceding word in same line.
2917 (skip-syntax-backward "^w_"
2918 (save-excursion (beginning-of-line)
2919 (point)))
2920 (if (bolp)
2921 ;; No preceding word in same line.
2922 ;; Look for following word in same line.
2923 (progn
2924 (skip-syntax-forward "^w_"
2925 (save-excursion (end-of-line)
2926 (point)))
2927 (setq start (point))
2928 (skip-syntax-forward "w_")
2929 (setq end (point)))
2930 (setq end (point))
2931 (skip-syntax-backward "w_")
2932 (setq start (point)))
020db25f
RS
2933 (buffer-substring-no-properties start end)))
2934 (buffer-substring-no-properties start end)))))
2076c87c 2935\f
69c1dd37 2936(defcustom fill-prefix nil
2076c87c 2937 "*String for filling to insert at front of new line, or nil for none.
69c1dd37
RS
2938Setting this variable automatically makes it local to the current buffer."
2939 :type '(choice (const :tag "None" nil)
2940 string)
2941 :group 'fill)
2076c87c
JB
2942(make-variable-buffer-local 'fill-prefix)
2943
69c1dd37
RS
2944(defcustom auto-fill-inhibit-regexp nil
2945 "*Regexp to match lines which should not be auto-filled."
2946 :type '(choice (const :tag "None" nil)
2947 regexp)
2948 :group 'fill)
2076c87c 2949
b3ac9fa9
RS
2950(defvar comment-line-break-function 'indent-new-comment-line
2951 "*Mode-specific function which line breaks and continues a comment.
2952
2953This function is only called during auto-filling of a comment section.
2954The function should take a single optional argument, which is a flag
2955indicating whether it should use soft newlines.
2956
2957Setting this variable automatically makes it local to the current buffer.")
2958
dbe524b6 2959;; This function is used as the auto-fill-function of a buffer
e2504204
KH
2960;; when Auto-Fill mode is enabled.
2961;; It returns t if it really did any work.
dbe524b6
RS
2962;; (Actually some major modes use a different auto-fill function,
2963;; but this one is the default one.)
2076c87c 2964(defun do-auto-fill ()
a0170800
RS
2965 (let (fc justify bol give-up
2966 (fill-prefix fill-prefix))
c18465c4 2967 (if (or (not (setq justify (current-justification)))
8f066a20
RS
2968 (null (setq fc (current-fill-column)))
2969 (and (eq justify 'left)
2970 (<= (current-column) fc))
eed5698b
RS
2971 (save-excursion (beginning-of-line)
2972 (setq bol (point))
2973 (and auto-fill-inhibit-regexp
2974 (looking-at auto-fill-inhibit-regexp))))
2975 nil ;; Auto-filling not required
3db1e3b5
BG
2976 (if (memq justify '(full center right))
2977 (save-excursion (unjustify-current-line)))
a0170800
RS
2978
2979 ;; Choose a fill-prefix automatically.
2980 (if (and adaptive-fill-mode
2981 (or (null fill-prefix) (string= fill-prefix "")))
e4b62d7c
RS
2982 (let ((prefix
2983 (fill-context-prefix
2984 (save-excursion (backward-paragraph 1) (point))
50be475d 2985 (save-excursion (forward-paragraph 1) (point)))))
e4b62d7c
RS
2986 (and prefix (not (equal prefix ""))
2987 (setq fill-prefix prefix))))
a0170800 2988
eed5698b 2989 (while (and (not give-up) (> (current-column) fc))
e47d38f6 2990 ;; Determine where to split the line.
db893d00
RS
2991 (let* (after-prefix
2992 (fill-point
2993 (let ((opoint (point))
2994 bounce
2995 (first t))
2996 (save-excursion
2997 (beginning-of-line)
2998 (setq after-prefix (point))
2999 (and fill-prefix
3000 (looking-at (regexp-quote fill-prefix))
3001 (setq after-prefix (match-end 0)))
3002 (move-to-column (1+ fc))
dbe524b6
RS
3003 ;; Move back to the point where we can break the line.
3004 ;; We break the line between word or
db893d00
RS
3005 ;; after/before the character which has character
3006 ;; category `|'. We search space, \c| followed by
dbe524b6 3007 ;; a character, or \c| following a character. If
db893d00
RS
3008 ;; not found, place the point at beginning of line.
3009 (while (or first
3010 ;; If this is after period and a single space,
3011 ;; move back once more--we don't want to break
3012 ;; the line there and make it look like a
3013 ;; sentence end.
3014 (and (not (bobp))
3015 (not bounce)
3016 sentence-end-double-space
3017 (save-excursion (forward-char -1)
3018 (and (looking-at "\\. ")
dbe524b6
RS
3019 (not (looking-at "\\. ")))))
3020 (and (not (bobp))
3021 (not bounce)
3022 fill-nobreak-predicate
3023 (funcall fill-nobreak-predicate)))
db893d00
RS
3024 (setq first nil)
3025 (re-search-backward "[ \t]\\|\\c|.\\|.\\c|\\|^")
3026 ;; If we find nowhere on the line to break it,
3027 ;; break after one word. Set bounce to t
3028 ;; so we will not keep going in this while loop.
3029 (if (<= (point) after-prefix)
3030 (progn
3031 (goto-char after-prefix)
3032 (re-search-forward "[ \t]" opoint t)
3033 (setq bounce t))
3034 (if (looking-at "[ \t]")
3035 ;; Break the line at word boundary.
3036 (skip-chars-backward " \t")
3037 ;; Break the line after/before \c|.
3038 (forward-char 1))))
22c47bc5 3039 (if enable-multibyte-characters
eb400532
KH
3040 ;; If we are going to break the line after or
3041 ;; before a non-ascii character, we may have
3042 ;; to run a special function for the charset
3043 ;; of the character to find the correct break
3044 ;; point.
3045 (if (not (and (eq (charset-after (1- (point))) 'ascii)
3046 (eq (charset-after (point)) 'ascii)))
3047 (fill-find-break-point after-prefix)))
3048
db893d00 3049 ;; Let fill-point be set to the place where we end up.
4b9c8a06
RS
3050 ;; But move back before any whitespace here.
3051 (skip-chars-backward " \t")
db893d00
RS
3052 (point)))))
3053
3054 ;; See whether the place we found is any good.
e47d38f6
RS
3055 (if (save-excursion
3056 (goto-char fill-point)
07f458c1 3057 (and (not (bolp))
db893d00
RS
3058 ;; There is no use breaking at end of line.
3059 (not (save-excursion (skip-chars-forward " ") (eolp)))
3060 ;; It is futile to split at the end of the prefix
3061 ;; since we would just insert the prefix again.
3062 (not (and after-prefix (<= (point) after-prefix)))
07f458c1
RS
3063 ;; Don't split right after a comment starter
3064 ;; since we would just make another comment starter.
3065 (not (and comment-start-skip
3066 (let ((limit (point)))
3067 (beginning-of-line)
3068 (and (re-search-forward comment-start-skip
3069 limit t)
3070 (eq (point) limit)))))))
db893d00 3071 ;; Ok, we have a useful place to break the line. Do it.
e47d38f6
RS
3072 (let ((prev-column (current-column)))
3073 ;; If point is at the fill-point, do not `save-excursion'.
3074 ;; Otherwise, if a comment prefix or fill-prefix is inserted,
3075 ;; point will end up before it rather than after it.
3076 (if (save-excursion
3077 (skip-chars-backward " \t")
3078 (= (point) fill-point))
b3ac9fa9 3079 (funcall comment-line-break-function t)
e47d38f6
RS
3080 (save-excursion
3081 (goto-char fill-point)
b3ac9fa9 3082 (funcall comment-line-break-function t)))
e47d38f6
RS
3083 ;; Now do justification, if required
3084 (if (not (eq justify 'left))
3085 (save-excursion
3086 (end-of-line 0)
3087 (justify-current-line justify nil t)))
3088 ;; If making the new line didn't reduce the hpos of
3089 ;; the end of the line, then give up now;
3090 ;; trying again will not help.
3091 (if (>= (current-column) prev-column)
3092 (setq give-up t)))
db893d00 3093 ;; No good place to break => stop trying.
e47d38f6 3094 (setq give-up t))))
24ebf92e 3095 ;; Justify last line.
e2504204
KH
3096 (justify-current-line justify t t)
3097 t)))
2076c87c 3098
24ebf92e
RS
3099(defvar normal-auto-fill-function 'do-auto-fill
3100 "The function to use for `auto-fill-function' if Auto Fill mode is turned on.
3101Some major modes set this.")
3102
d7465b15 3103(defun auto-fill-mode (&optional arg)
24ebf92e
RS
3104 "Toggle Auto Fill mode.
3105With arg, turn Auto Fill mode on if and only if arg is positive.
3106In Auto Fill mode, inserting a space at a column beyond `current-fill-column'
3107automatically breaks the line at a previous space.
3108
3109The value of `normal-auto-fill-function' specifies the function to use
3110for `auto-fill-function' when turning Auto Fill mode on."
d7465b15
RS
3111 (interactive "P")
3112 (prog1 (setq auto-fill-function
3113 (if (if (null arg)
3114 (not auto-fill-function)
3115 (> (prefix-numeric-value arg) 0))
24ebf92e 3116 normal-auto-fill-function
d7465b15 3117 nil))
7911ecc8 3118 (force-mode-line-update)))
d7465b15
RS
3119
3120;; This holds a document string used to document auto-fill-mode.
3121(defun auto-fill-function ()
3122 "Automatically break line at a previous space, in insertion of text."
3123 nil)
3124
3125(defun turn-on-auto-fill ()
3126 "Unconditionally turn on Auto Fill mode."
3127 (auto-fill-mode 1))
7cbf1dc1 3128(custom-add-option 'text-mode-hook 'turn-on-auto-fill)
d7465b15
RS
3129
3130(defun set-fill-column (arg)
4cc0ea11 3131 "Set `fill-column' to specified argument.
923efb99 3132Use \\[universal-argument] followed by a number to specify a column.
4cc0ea11 3133Just \\[universal-argument] as argument means to use the current column."
d7465b15 3134 (interactive "P")
f4520363
RS
3135 (if (consp arg)
3136 (setq arg (current-column)))
3137 (if (not (integerp arg))
3138 ;; Disallow missing argument; it's probably a typo for C-x C-f.
3139 (error "set-fill-column requires an explicit argument")
3140 (message "Fill column set to %d (was %d)" arg fill-column)
3141 (setq fill-column arg)))
d7465b15 3142\f
69c1dd37 3143(defcustom comment-multi-line nil
2076c87c 3144 "*Non-nil means \\[indent-new-comment-line] should continue same comment
c88ab9ce 3145on new line, with no new terminator or starter.
69c1dd37
RS
3146This is obsolete because you might as well use \\[newline-and-indent]."
3147 :type 'boolean
3148 :group 'fill-comments)
2076c87c 3149
28191e20 3150(defun indent-new-comment-line (&optional soft)
d7465b15
RS
3151 "Break line at point and indent, continuing comment if within one.
3152This indents the body of the continued comment
3153under the previous comment line.
c88ab9ce
ER
3154
3155This command is intended for styles where you write a comment per line,
3156starting a new comment (and terminating it if necessary) on each line.
28191e20
RS
3157If you want to continue one comment across several lines, use \\[newline-and-indent].
3158
3a0c4755
RS
3159If a fill column is specified, it overrides the use of the comment column
3160or comment indentation.
3161
28191e20
RS
3162The inserted newline is marked hard if `use-hard-newlines' is true,
3163unless optional argument SOFT is non-nil."
3164 (interactive)
2076c87c
JB
3165 (let (comcol comstart)
3166 (skip-chars-backward " \t")
3167 (delete-region (point)
3168 (progn (skip-chars-forward " \t")
3169 (point)))
eed5698b 3170 (if soft (insert-and-inherit ?\n) (newline 1))
3a0c4755
RS
3171 (if fill-prefix
3172 (progn
3173 (indent-to-left-margin)
3174 (insert-and-inherit fill-prefix))
3175 (if (not comment-multi-line)
2076c87c 3176 (save-excursion
3a0c4755
RS
3177 (if (and comment-start-skip
3178 (let ((opoint (point)))
3179 (forward-line -1)
3180 (re-search-forward comment-start-skip opoint t)))
3181 ;; The old line is a comment.
3182 ;; Set WIN to the pos of the comment-start.
3183 ;; But if the comment is empty, look at preceding lines
3184 ;; to find one that has a nonempty comment.
3185
3186 ;; If comment-start-skip contains a \(...\) pair,
3187 ;; the real comment delimiter starts at the end of that pair.
3188 (let ((win (or (match-end 1) (match-beginning 0))))
3189 (while (and (eolp) (not (bobp))
3190 (let (opoint)
3191 (beginning-of-line)
3192 (setq opoint (point))
3193 (forward-line -1)
3194 (re-search-forward comment-start-skip opoint t)))
3195 (setq win (or (match-end 1) (match-beginning 0))))
3196 ;; Indent this line like what we found.
3197 (goto-char win)
3198 (setq comcol (current-column))
3199 (setq comstart
3200 (buffer-substring (point) (match-end 0)))))))
3201 (if comcol
3202 (let ((comment-column comcol)
3203 (comment-start comstart)
3204 (comment-end comment-end))
3205 (and comment-end (not (equal comment-end ""))
3206 ; (if (not comment-multi-line)
3207 (progn
3208 (forward-char -1)
3209 (insert comment-end)
3210 (forward-char 1))
3211 ; (setq comment-column (+ comment-column (length comment-start))
3212 ; comment-start "")
3213 ; )
3214 )
3215 (if (not (eolp))
3216 (setq comment-end ""))
3217 (insert-and-inherit ?\n)
3218 (forward-char -1)
3219 (indent-for-comment)
3220 (save-excursion
3221 ;; Make sure we delete the newline inserted above.
3222 (end-of-line)
3223 (delete-char 1)))
3224 (indent-according-to-mode)))))
2076c87c
JB
3225\f
3226(defun set-selective-display (arg)
ff1fbe3e
RS
3227 "Set `selective-display' to ARG; clear it if no arg.
3228When the value of `selective-display' is a number > 0,
3229lines whose indentation is >= that value are not displayed.
3230The variable `selective-display' has a separate value for each buffer."
2076c87c
JB
3231 (interactive "P")
3232 (if (eq selective-display t)
3233 (error "selective-display already in use for marked lines"))
c88ab9ce
ER
3234 (let ((current-vpos
3235 (save-restriction
3236 (narrow-to-region (point-min) (point))
3237 (goto-char (window-start))
3238 (vertical-motion (window-height)))))
3239 (setq selective-display
3240 (and arg (prefix-numeric-value arg)))
3241 (recenter current-vpos))
2076c87c
JB
3242 (set-window-start (selected-window) (window-start (selected-window)))
3243 (princ "selective-display set to " t)
3244 (prin1 selective-display t)
3245 (princ "." t))
3246
4f8f7f9f 3247(defvar overwrite-mode-textual " Ovwrt"
b6a22db0 3248 "The string displayed in the mode line when in overwrite mode.")
4f8f7f9f 3249(defvar overwrite-mode-binary " Bin Ovwrt"
b6a22db0
JB
3250 "The string displayed in the mode line when in binary overwrite mode.")
3251
2076c87c
JB
3252(defun overwrite-mode (arg)
3253 "Toggle overwrite mode.
3254With arg, turn overwrite mode on iff arg is positive.
3255In overwrite mode, printing characters typed in replace existing text
b6a22db0
JB
3256on a one-for-one basis, rather than pushing it to the right. At the
3257end of a line, such characters extend the line. Before a tab,
3258such characters insert until the tab is filled in.
3259\\[quoted-insert] still inserts characters in overwrite mode; this
3260is supposed to make it easier to insert characters when necessary."
3261 (interactive "P")
3262 (setq overwrite-mode
3263 (if (if (null arg) (not overwrite-mode)
3264 (> (prefix-numeric-value arg) 0))
3265 'overwrite-mode-textual))
3266 (force-mode-line-update))
3267
3268(defun binary-overwrite-mode (arg)
3269 "Toggle binary overwrite mode.
3270With arg, turn binary overwrite mode on iff arg is positive.
3271In binary overwrite mode, printing characters typed in replace
3272existing text. Newlines are not treated specially, so typing at the
3273end of a line joins the line to the next, with the typed character
3274between them. Typing before a tab character simply replaces the tab
3275with the character typed.
3276\\[quoted-insert] replaces the text at the cursor, just as ordinary
3277typing characters do.
3278
3279Note that binary overwrite mode is not its own minor mode; it is a
3280specialization of overwrite-mode, entered by setting the
3281`overwrite-mode' variable to `overwrite-mode-binary'."
2076c87c
JB
3282 (interactive "P")
3283 (setq overwrite-mode
b6a22db0 3284 (if (if (null arg)
a61099dd 3285 (not (eq overwrite-mode 'overwrite-mode-binary))
b6a22db0
JB
3286 (> (prefix-numeric-value arg) 0))
3287 'overwrite-mode-binary))
3288 (force-mode-line-update))
2076c87c 3289\f
69c1dd37
RS
3290(defcustom line-number-mode t
3291 "*Non-nil means display line number in mode line."
3292 :type 'boolean
3293 :group 'editing-basics)
a61099dd
RS
3294
3295(defun line-number-mode (arg)
3296 "Toggle Line Number mode.
3297With arg, turn Line Number mode on iff arg is positive.
3298When Line Number mode is enabled, the line number appears
8dc9e2ef
KH
3299in the mode line.
3300
3301Line numbers do not appear for very large buffers, see variable
3302`line-number-display-limit'."
a61099dd
RS
3303 (interactive "P")
3304 (setq line-number-mode
3305 (if (null arg) (not line-number-mode)
3306 (> (prefix-numeric-value arg) 0)))
3307 (force-mode-line-update))
3308
69c1dd37
RS
3309(defcustom column-number-mode nil
3310 "*Non-nil means display column number in mode line."
3311 :type 'boolean
3312 :group 'editing-basics)
bcad4985
KH
3313
3314(defun column-number-mode (arg)
3315 "Toggle Column Number mode.
3316With arg, turn Column Number mode on iff arg is positive.
3317When Column Number mode is enabled, the column number appears
3318in the mode line."
3319 (interactive "P")
3320 (setq column-number-mode
3321 (if (null arg) (not column-number-mode)
3322 (> (prefix-numeric-value arg) 0)))
3323 (force-mode-line-update))
3324
4b384a8f 3325(defgroup paren-blinking nil
020db25f 3326 "Blinking matching of parens and expressions."
4b384a8f
SM
3327 :prefix "blink-matching-"
3328 :group 'paren-matching)
3329
69c1dd37
RS
3330(defcustom blink-matching-paren t
3331 "*Non-nil means show matching open-paren when close-paren is inserted."
3332 :type 'boolean
4b384a8f 3333 :group 'paren-blinking)
2076c87c 3334
69c1dd37 3335(defcustom blink-matching-paren-on-screen t
29fc44dd 3336 "*Non-nil means show matching open-paren when it is on screen.
4b384a8f
SM
3337If nil, means don't show it (but the open-paren can still be shown
3338when it is off screen)."
69c1dd37 3339 :type 'boolean
4b384a8f 3340 :group 'paren-blinking)
29fc44dd 3341
4b384a8f 3342(defcustom blink-matching-paren-distance (* 25 1024)
69c1dd37
RS
3343 "*If non-nil, is maximum distance to search for matching open-paren."
3344 :type 'integer
4b384a8f 3345 :group 'paren-blinking)
2076c87c 3346
69c1dd37 3347(defcustom blink-matching-delay 1
4b384a8f
SM
3348 "*Time in seconds to delay after showing a matching paren."
3349 :type 'number
3350 :group 'paren-blinking)
72dddf8b 3351
69c1dd37 3352(defcustom blink-matching-paren-dont-ignore-comments nil
4b384a8f 3353 "*Non-nil means `blink-matching-paren' will not ignore comments."
69c1dd37 3354 :type 'boolean
4b384a8f 3355 :group 'paren-blinking)
903b7f65 3356
2076c87c
JB
3357(defun blink-matching-open ()
3358 "Move cursor momentarily to the beginning of the sexp before point."
3359 (interactive)
3360 (and (> (point) (1+ (point-min)))
2076c87c 3361 blink-matching-paren
7e1ddd45
RS
3362 ;; Verify an even number of quoting characters precede the close.
3363 (= 1 (logand 1 (- (point)
3364 (save-excursion
3365 (forward-char -1)
3366 (skip-syntax-backward "/\\")
3367 (point)))))
2076c87c
JB
3368 (let* ((oldpos (point))
3369 (blinkpos)
3370 (mismatch))
3371 (save-excursion
3372 (save-restriction
3373 (if blink-matching-paren-distance
3374 (narrow-to-region (max (point-min)
3375 (- (point) blink-matching-paren-distance))
3376 oldpos))
3377 (condition-case ()
903b7f65
RS
3378 (let ((parse-sexp-ignore-comments
3379 (and parse-sexp-ignore-comments
3380 (not blink-matching-paren-dont-ignore-comments))))
3381 (setq blinkpos (scan-sexps oldpos -1)))
2076c87c 3382 (error nil)))
903b7f65
RS
3383 (and blinkpos
3384 (/= (char-syntax (char-after blinkpos))
3385 ?\$)
2076c87c 3386 (setq mismatch
903b7f65
RS
3387 (or (null (matching-paren (char-after blinkpos)))
3388 (/= (char-after (1- oldpos))
3389 (matching-paren (char-after blinkpos))))))
2076c87c
JB
3390 (if mismatch (setq blinkpos nil))
3391 (if blinkpos
a117eaee
KH
3392 ;; Don't log messages about paren matching.
3393 (let (message-log-max)
2076c87c
JB
3394 (goto-char blinkpos)
3395 (if (pos-visible-in-window-p)
29fc44dd
KH
3396 (and blink-matching-paren-on-screen
3397 (sit-for blink-matching-delay))
2076c87c
JB
3398 (goto-char blinkpos)
3399 (message
3400 "Matches %s"
e9f1d66d 3401 ;; Show what precedes the open in its line, if anything.
2076c87c
JB
3402 (if (save-excursion
3403 (skip-chars-backward " \t")
3404 (not (bolp)))
3405 (buffer-substring (progn (beginning-of-line) (point))
3406 (1+ blinkpos))
e9f1d66d
RS
3407 ;; Show what follows the open in its line, if anything.
3408 (if (save-excursion
3409 (forward-char 1)
3410 (skip-chars-forward " \t")
3411 (not (eolp)))
3412 (buffer-substring blinkpos
3413 (progn (end-of-line) (point)))
267935b9
RS
3414 ;; Otherwise show the previous nonblank line,
3415 ;; if there is one.
3416 (if (save-excursion
3417 (skip-chars-backward "\n \t")
3418 (not (bobp)))
3419 (concat
3420 (buffer-substring (progn
3421 (skip-chars-backward "\n \t")
3422 (beginning-of-line)
3423 (point))
3424 (progn (end-of-line)
3425 (skip-chars-backward " \t")
3426 (point)))
3427 ;; Replace the newline and other whitespace with `...'.
3428 "..."
3429 (buffer-substring blinkpos (1+ blinkpos)))
3430 ;; There is nothing to show except the char itself.
3431 (buffer-substring blinkpos (1+ blinkpos))))))))
2076c87c
JB
3432 (cond (mismatch
3433 (message "Mismatched parentheses"))
3434 ((not blink-matching-paren-distance)
3435 (message "Unmatched parenthesis"))))))))
3436
3437;Turned off because it makes dbx bomb out.
3438(setq blink-paren-function 'blink-matching-open)
3439
9a1277dd
RS
3440;; This executes C-g typed while Emacs is waiting for a command.
3441;; Quitting out of a program does not go through here;
3442;; that happens in the QUIT macro at the C code level.
2076c87c 3443(defun keyboard-quit ()
d5dae4e1 3444 "Signal a `quit' condition.
af39530e
RS
3445During execution of Lisp code, this character causes a quit directly.
3446At top-level, as an editor command, this simply beeps."
2076c87c 3447 (interactive)
19d35374 3448 (deactivate-mark)
2076c87c
JB
3449 (signal 'quit nil))
3450
3451(define-key global-map "\C-g" 'keyboard-quit)
c66587fe 3452
1c6c6fde
RS
3453(defvar buffer-quit-function nil
3454 "Function to call to \"quit\" the current buffer, or nil if none.
3455\\[keyboard-escape-quit] calls this function when its more local actions
3456\(such as cancelling a prefix argument, minibuffer or region) do not apply.")
3457
c66587fe
RS
3458(defun keyboard-escape-quit ()
3459 "Exit the current \"mode\" (in a generalized sense of the word).
3460This command can exit an interactive command such as `query-replace',
3461can clear out a prefix argument or a region,
3462can get out of the minibuffer or other recursive edit,
1c6c6fde
RS
3463cancel the use of the current buffer (for special-purpose buffers),
3464or go back to just one window (by deleting all but the selected window)."
c66587fe
RS
3465 (interactive)
3466 (cond ((eq last-command 'mode-exited) nil)
3467 ((> (minibuffer-depth) 0)
3468 (abort-recursive-edit))
3469 (current-prefix-arg
3470 nil)
3471 ((and transient-mark-mode
3472 mark-active)
3473 (deactivate-mark))
1b657835
RS
3474 ((> (recursion-depth) 0)
3475 (exit-recursive-edit))
1c6c6fde
RS
3476 (buffer-quit-function
3477 (funcall buffer-quit-function))
c66587fe 3478 ((not (one-window-p t))
1b657835
RS
3479 (delete-other-windows))
3480 ((string-match "^ \\*" (buffer-name (current-buffer)))
3481 (bury-buffer))))
c66587fe 3482
1c6c6fde 3483(define-key global-map "\e\e\e" 'keyboard-escape-quit)
2076c87c 3484\f
69c1dd37 3485(defcustom mail-user-agent 'sendmail-user-agent
a31ca314
RS
3486 "*Your preference for a mail composition package.
3487Various Emacs Lisp packages (e.g. reporter) require you to compose an
3488outgoing email message. This variable lets you specify which
3489mail-sending package you prefer.
3490
3491Valid values include:
3492
3183b230
RS
3493 sendmail-user-agent -- use the default Emacs Mail package
3494 mh-e-user-agent -- use the Emacs interface to the MH mail system
3495 message-user-agent -- use the GNUS mail sending package
a31ca314
RS
3496
3497Additional valid symbols may be available; check with the author of
69c1dd37
RS
3498your package for details."
3499 :type '(radio (function-item :tag "Default Emacs mail"
3500 :format "%t\n"
3501 sendmail-user-agent)
3502 (function-item :tag "Emacs interface to MH"
3503 :format "%t\n"
3504 mh-e-user-agent)
3505 (function-item :tag "Gnus mail sending package"
3506 :format "%t\n"
3507 message-user-agent)
3508 (function :tag "Other"))
3509 :group 'mail)
a31ca314
RS
3510
3511(defun define-mail-user-agent (symbol composefunc sendfunc
3512 &optional abortfunc hookvar)
3513 "Define a symbol to identify a mail-sending package for `mail-user-agent'.
3514
3515SYMBOL can be any Lisp symbol. Its function definition and/or
3516value as a variable do not matter for this usage; we use only certain
3517properties on its property list, to encode the rest of the arguments.
3518
3519COMPOSEFUNC is program callable function that composes an outgoing
3520mail message buffer. This function should set up the basics of the
3521buffer without requiring user interaction. It should populate the
3183b230
RS
3522standard mail headers, leaving the `to:' and `subject:' headers blank
3523by default.
a31ca314 3524
d0008a00
RS
3525COMPOSEFUNC should accept several optional arguments--the same
3526arguments that `compose-mail' takes. See that function's documentation.
a31ca314 3527
3183b230
RS
3528SENDFUNC is the command a user would run to send the message.
3529
3530Optional ABORTFUNC is the command a user would run to abort the
a31ca314
RS
3531message. For mail packages that don't have a separate abort function,
3532this can be `kill-buffer' (the equivalent of omitting this argument).
3533
3534Optional HOOKVAR is a hook variable that gets run before the message
3183b230
RS
3535is actually sent. Callers that use the `mail-user-agent' may
3536install a hook function temporarily on this hook variable.
3537If HOOKVAR is nil, `mail-send-hook' is used.
a31ca314
RS
3538
3539The properties used on SYMBOL are `composefunc', `sendfunc',
3540`abortfunc', and `hookvar'."
3541 (put symbol 'composefunc composefunc)
3542 (put symbol 'sendfunc sendfunc)
3543 (put symbol 'abortfunc (or abortfunc 'kill-buffer))
3544 (put symbol 'hookvar (or hookvar 'mail-send-hook)))
3545
d0008a00 3546(defun assoc-ignore-case (key alist)
9f0f00d7
RS
3547 "Like `assoc', but ignores differences in case and text representation.
3548KEY must be a string. Upper-case and lower-case letters are treated as equal.
3549Unibyte strings are converted to multibyte for comparison."
d0008a00
RS
3550 (let (element)
3551 (while (and alist (not element))
9f0f00d7
RS
3552 (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t))
3553 (setq element (car alist)))
3554 (setq alist (cdr alist)))
3555 element))
3556
3557(defun assoc-ignore-representation (key alist)
3558 "Like `assoc', but ignores differences in text representation.
3559KEY must be a string.
3560Unibyte strings are converted to multibyte for comparison."
3561 (let (element)
3562 (while (and alist (not element))
3563 (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil))
d0008a00
RS
3564 (setq element (car alist)))
3565 (setq alist (cdr alist)))
3566 element))
3567
a31ca314 3568(define-mail-user-agent 'sendmail-user-agent
34fbcdf3 3569 'sendmail-user-agent-compose
a31ca314
RS
3570 'mail-send-and-exit)
3571
360b5483
RS
3572(defun rfc822-goto-eoh ()
3573 ;; Go to header delimiter line in a mail message, following RFC822 rules
3574 (goto-char (point-min))
3575 (while (looking-at "^[^: \n]+:\\|^[ \t]")
3576 (forward-line 1))
3577 (point))
3578
34fbcdf3
RS
3579(defun sendmail-user-agent-compose (&optional to subject other-headers continue
3580 switch-function yank-action
3581 send-actions)
3582 (if switch-function
3583 (let ((special-display-buffer-names nil)
3584 (special-display-regexps nil)
3585 (same-window-buffer-names nil)
3586 (same-window-regexps nil))
3587 (funcall switch-function "*mail*")))
3588 (let ((cc (cdr (assoc-ignore-case "cc" other-headers)))
3589 (in-reply-to (cdr (assoc-ignore-case "in-reply-to" other-headers))))
3590 (or (mail continue to subject in-reply-to cc yank-action send-actions)
3591 continue
3592 (error "Message aborted"))
3593 (save-excursion
360b5483 3594 (rfc822-goto-eoh)
34fbcdf3
RS
3595 (while other-headers
3596 (if (not (member (car (car other-headers)) '("in-reply-to" "cc")))
3597 (insert (car (car other-headers)) ": "
3598 (cdr (car other-headers)) "\n"))
3599 (setq other-headers (cdr other-headers)))
3600 t)))
3601
a31ca314
RS
3602(define-mail-user-agent 'mh-e-user-agent
3603 'mh-smail-batch 'mh-send-letter 'mh-fully-kill-draft
3604 'mh-before-send-letter-hook)
d0008a00
RS
3605
3606(defun compose-mail (&optional to subject other-headers continue
3607 switch-function yank-action send-actions)
3608 "Start composing a mail message to send.
3609This uses the user's chosen mail composition package
3610as selected with the variable `mail-user-agent'.
3611The optional arguments TO and SUBJECT specify recipients
3612and the initial Subject field, respectively.
3613
3614OTHER-HEADERS is an alist specifying additional
3615header fields. Elements look like (HEADER . VALUE) where both
3616HEADER and VALUE are strings.
3617
3618CONTINUE, if non-nil, says to continue editing a message already
3619being composed.
3620
3621SWITCH-FUNCTION, if non-nil, is a function to use to
3622switch to and display the buffer used for mail composition.
3623
3624YANK-ACTION, if non-nil, is an action to perform, if and when necessary,
06720de2
RS
3625to insert the raw text of the message being replied to.
3626It has the form (FUNCTION . ARGS). The user agent will apply
3627FUNCTION to ARGS, to insert the raw text of the original message.
3628\(The user agent will also run `mail-citation-hook', *after* the
3629original text has been inserted in this way.)
d0008a00
RS
3630
3631SEND-ACTIONS is a list of actions to call when the message is sent.
3632Each action has the form (FUNCTION . ARGS)."
b5f019be
RS
3633 (interactive
3634 (list nil nil nil current-prefix-arg))
d0008a00
RS
3635 (let ((function (get mail-user-agent 'composefunc)))
3636 (funcall function to subject other-headers continue
3637 switch-function yank-action send-actions)))
b5f019be
RS
3638
3639(defun compose-mail-other-window (&optional to subject other-headers continue
3640 yank-action send-actions)
3641 "Like \\[compose-mail], but edit the outgoing message in another window."
3642 (interactive
3643 (list nil nil nil current-prefix-arg))
3644 (compose-mail to subject other-headers continue
3645 'switch-to-buffer-other-window yank-action send-actions))
3646
3647
3648(defun compose-mail-other-frame (&optional to subject other-headers continue
3649 yank-action send-actions)
3650 "Like \\[compose-mail], but edit the outgoing message in another frame."
3651 (interactive
3652 (list nil nil nil current-prefix-arg))
3653 (compose-mail to subject other-headers continue
3654 'switch-to-buffer-other-frame yank-action send-actions))
a31ca314 3655\f
610c1c68
RS
3656(defvar set-variable-value-history nil
3657 "History of values entered with `set-variable'.")
3658
3659(defun set-variable (var val)
3660 "Set VARIABLE to VALUE. VALUE is a Lisp object.
3661When using this interactively, enter a Lisp object for VALUE.
3662If you want VALUE to be a string, you must surround it with doublequotes.
3663VALUE is used literally, not evaluated.
3664
3665If VARIABLE has a `variable-interactive' property, that is used as if
3666it were the arg to `interactive' (which see) to interactively read VALUE.
3667
3668If VARIABLE has been defined with `defcustom', then the type information
3669in the definition is used to check that VALUE is valid."
e9dfb72e
RS
3670 (interactive
3671 (let* ((default-var (variable-at-point))
3672 (var (if (symbolp default-var)
3673 (read-variable (format "Set variable (default %s): " default-var)
3674 default-var)
3675 (read-variable "Set variable: ")))
610c1c68
RS
3676 (minibuffer-help-form '(describe-variable var))
3677 (prop (get var 'variable-interactive))
3678 (prompt (format "Set %s to value: " var))
3679 (val (if prop
3680 ;; Use VAR's `variable-interactive' property
3681 ;; as an interactive spec for prompting.
3682 (call-interactively `(lambda (arg)
3683 (interactive ,prop)
3684 arg))
3685 (read
3686 (read-string prompt nil
3687 'set-variable-value-history)))))
3688 (list var val)))
3689
f8496faa 3690 (let ((type (get var 'custom-type)))
610c1c68
RS
3691 (when type
3692 ;; Match with custom type.
3693 (require 'wid-edit)
610c1c68
RS
3694 (setq type (widget-convert type))
3695 (unless (widget-apply type :match val)
3696 (error "Value `%S' does not match type %S of %S"
3697 val (car type) var))))
3698 (set var val))
e8a700bf
RS
3699\f
3700;; Define the major mode for lists of completions.
3701
98b45886
RS
3702(defvar completion-list-mode-map nil
3703 "Local map for completion list buffers.")
ac29eb79 3704(or completion-list-mode-map
e8a700bf
RS
3705 (let ((map (make-sparse-keymap)))
3706 (define-key map [mouse-2] 'mouse-choose-completion)
eaf76065 3707 (define-key map [down-mouse-2] nil)
80298193 3708 (define-key map "\C-m" 'choose-completion)
1c6c6fde 3709 (define-key map "\e\e\e" 'delete-completion-window)
dde69dbe
RS
3710 (define-key map [left] 'previous-completion)
3711 (define-key map [right] 'next-completion)
ac29eb79 3712 (setq completion-list-mode-map map)))
e8a700bf
RS
3713
3714;; Completion mode is suitable only for specially formatted data.
ac29eb79 3715(put 'completion-list-mode 'mode-class 'special)
e8a700bf 3716
98b45886
RS
3717(defvar completion-reference-buffer nil
3718 "Record the buffer that was current when the completion list was requested.
3719This is a local variable in the completion list buffer.
ec39964e 3720Initial value is nil to avoid some compiler warnings.")
3819736b 3721
83434bda
RS
3722(defvar completion-no-auto-exit nil
3723 "Non-nil means `choose-completion-string' should never exit the minibuffer.
3724This also applies to other functions such as `choose-completion'
3725and `mouse-choose-completion'.")
3726
98b45886
RS
3727(defvar completion-base-size nil
3728 "Number of chars at beginning of minibuffer not involved in completion.
3729This is a local variable in the completion list buffer
3730but it talks about the buffer in `completion-reference-buffer'.
3731If this is nil, it means to compare text to determine which part
3732of the tail end of the buffer's text is involved in completion.")
f6b293e3 3733
1c6c6fde
RS
3734(defun delete-completion-window ()
3735 "Delete the completion list window.
3736Go to the window from which completion was requested."
3737 (interactive)
3738 (let ((buf completion-reference-buffer))
ddb2b181
RS
3739 (if (one-window-p t)
3740 (if (window-dedicated-p (selected-window))
3741 (delete-frame (selected-frame)))
3742 (delete-window (selected-window))
3743 (if (get-buffer-window buf)
3744 (select-window (get-buffer-window buf))))))
1c6c6fde 3745
dde69dbe
RS
3746(defun previous-completion (n)
3747 "Move to the previous item in the completion list."
3748 (interactive "p")
3749 (next-completion (- n)))
3750
3751(defun next-completion (n)
3752 "Move to the next item in the completion list.
1f238ac2 3753With prefix argument N, move N items (negative N means move backward)."
dde69dbe
RS
3754 (interactive "p")
3755 (while (and (> n 0) (not (eobp)))
b61a81c2
RS
3756 (let ((prop (get-text-property (point) 'mouse-face))
3757 (end (point-max)))
dde69dbe
RS
3758 ;; If in a completion, move to the end of it.
3759 (if prop
b61a81c2 3760 (goto-char (next-single-property-change (point) 'mouse-face nil end)))
dde69dbe 3761 ;; Move to start of next one.
b61a81c2 3762 (goto-char (next-single-property-change (point) 'mouse-face nil end)))
dde69dbe
RS
3763 (setq n (1- n)))
3764 (while (and (< n 0) (not (bobp)))
b61a81c2
RS
3765 (let ((prop (get-text-property (1- (point)) 'mouse-face))
3766 (end (point-min)))
dde69dbe
RS
3767 ;; If in a completion, move to the start of it.
3768 (if prop
b61a81c2
RS
3769 (goto-char (previous-single-property-change
3770 (point) 'mouse-face nil end)))
dde69dbe 3771 ;; Move to end of the previous completion.
b61a81c2 3772 (goto-char (previous-single-property-change (point) 'mouse-face nil end))
dde69dbe 3773 ;; Move to the start of that one.
b61a81c2 3774 (goto-char (previous-single-property-change (point) 'mouse-face nil end)))
dde69dbe
RS
3775 (setq n (1+ n))))
3776
80298193
RS
3777(defun choose-completion ()
3778 "Choose the completion that point is in or next to."
3779 (interactive)
f6b293e3
RS
3780 (let (beg end completion (buffer completion-reference-buffer)
3781 (base-size completion-base-size))
6096f362
RS
3782 (if (and (not (eobp)) (get-text-property (point) 'mouse-face))
3783 (setq end (point) beg (1+ (point))))
3784 (if (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face))
3f299281 3785 (setq end (1- (point)) beg (point)))
6096f362
RS
3786 (if (null beg)
3787 (error "No completion here"))
3788 (setq beg (previous-single-property-change beg 'mouse-face))
88dd3c24 3789 (setq end (or (next-single-property-change end 'mouse-face) (point-max)))
ab63960f
RS
3790 (setq completion (buffer-substring beg end))
3791 (let ((owindow (selected-window)))
3792 (if (and (one-window-p t 'selected-frame)
3793 (window-dedicated-p (selected-window)))
3794 ;; This is a special buffer's frame
3795 (iconify-frame (selected-frame))
3796 (or (window-dedicated-p (selected-window))
3797 (bury-buffer)))
3798 (select-window owindow))
f6b293e3 3799 (choose-completion-string completion buffer base-size)))
80298193
RS
3800
3801;; Delete the longest partial match for STRING
3802;; that can be found before POINT.
3803(defun choose-completion-delete-max-match (string)
3804 (let ((opoint (point))
3805 (len (min (length string)
3806 (- (point) (point-min)))))
3807 (goto-char (- (point) (length string)))
61bbf6fe
RS
3808 (if completion-ignore-case
3809 (setq string (downcase string)))
80298193
RS
3810 (while (and (> len 0)
3811 (let ((tail (buffer-substring (point)
3812 (+ (point) len))))
61bbf6fe
RS
3813 (if completion-ignore-case
3814 (setq tail (downcase tail)))
80298193
RS
3815 (not (string= tail (substring string 0 len)))))
3816 (setq len (1- len))
3817 (forward-char 1))
3818 (delete-char len)))
3819
98b45886
RS
3820;; Switch to BUFFER and insert the completion choice CHOICE.
3821;; BASE-SIZE, if non-nil, says how many characters of BUFFER's text
3822;; to keep. If it is nil, use choose-completion-delete-max-match instead.
74d0290b
RS
3823
3824;; If BUFFER is the minibuffer, exit the minibuffer
83434bda
RS
3825;; unless it is reading a file name and CHOICE is a directory,
3826;; or completion-no-auto-exit is non-nil.
f6b293e3 3827(defun choose-completion-string (choice &optional buffer base-size)
80298193 3828 (let ((buffer (or buffer completion-reference-buffer)))
cf52ad58
RS
3829 ;; If BUFFER is a minibuffer, barf unless it's the currently
3830 ;; active minibuffer.
3831 (if (and (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer))
45486731
RS
3832 (or (not (active-minibuffer-window))
3833 (not (equal buffer
3834 (window-buffer (active-minibuffer-window))))))
cf52ad58
RS
3835 (error "Minibuffer is not active for completion")
3836 ;; Insert the completion into the buffer where completion was requested.
3837 (set-buffer buffer)
f6b293e3
RS
3838 (if base-size
3839 (delete-region (+ base-size (point-min)) (point))
3840 (choose-completion-delete-max-match choice))
cf52ad58 3841 (insert choice)
63240af1
RS
3842 (remove-text-properties (- (point) (length choice)) (point)
3843 '(mouse-face nil))
cf52ad58
RS
3844 ;; Update point in the window that BUFFER is showing in.
3845 (let ((window (get-buffer-window buffer t)))
3846 (set-window-point window (point)))
3847 ;; If completing for the minibuffer, exit it with this choice.
83434bda
RS
3848 (and (not completion-no-auto-exit)
3849 (equal buffer (window-buffer (minibuffer-window)))
8881ad9a 3850 minibuffer-completion-table
74d0290b
RS
3851 ;; If this is reading a file name, and the file name chosen
3852 ;; is a directory, don't exit the minibuffer.
3853 (if (and (eq minibuffer-completion-table 'read-file-name-internal)
3854 (file-directory-p (buffer-string)))
3855 (select-window (active-minibuffer-window))
3856 (exit-minibuffer))))))
80298193 3857
ac29eb79 3858(defun completion-list-mode ()
e8a700bf 3859 "Major mode for buffers showing lists of possible completions.
80298193
RS
3860Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\
3861 to select the completion near point.
3862Use \\<completion-list-mode-map>\\[mouse-choose-completion] to select one\
3863 with the mouse."
e8a700bf
RS
3864 (interactive)
3865 (kill-all-local-variables)
ac29eb79
RS
3866 (use-local-map completion-list-mode-map)
3867 (setq mode-name "Completion List")
3868 (setq major-mode 'completion-list-mode)
f6b293e3
RS
3869 (make-local-variable 'completion-base-size)
3870 (setq completion-base-size nil)
ac29eb79 3871 (run-hooks 'completion-list-mode-hook))
e8a700bf 3872
747a0e2f
RS
3873(defvar completion-setup-hook nil
3874 "Normal hook run at the end of setting up a completion list buffer.
3875When this hook is run, the current buffer is the one in which the
3876command to display the completion list buffer was run.
3877The completion list buffer is available as the value of `standard-output'.")
3878
98b45886
RS
3879;; This function goes in completion-setup-hook, so that it is called
3880;; after the text of the completion list buffer is written.
6096f362 3881
e8a700bf
RS
3882(defun completion-setup-function ()
3883 (save-excursion
98b45886 3884 (let ((mainbuf (current-buffer)))
3819736b
RS
3885 (set-buffer standard-output)
3886 (completion-list-mode)
3887 (make-local-variable 'completion-reference-buffer)
3888 (setq completion-reference-buffer mainbuf)
50be475d
RS
3889 (if (eq minibuffer-completion-table 'read-file-name-internal)
3890 ;; For file name completion,
3891 ;; use the number of chars before the start of the
3892 ;; last file name component.
3893 (setq completion-base-size
3894 (save-excursion
3895 (set-buffer mainbuf)
3896 (goto-char (point-max))
3897 (skip-chars-backward (format "^%c" directory-sep-char))
3898 (- (point) (point-min))))
19183a29
RS
3899 ;; Otherwise, in minibuffer, the whole input is being completed.
3900 (save-match-data
3901 (if (string-match "\\` \\*Minibuf-[0-9]+\\*\\'"
3902 (buffer-name mainbuf))
3903 (setq completion-base-size 0))))
3819736b
RS
3904 (goto-char (point-min))
3905 (if window-system
3906 (insert (substitute-command-keys
80298193
RS
3907 "Click \\[mouse-choose-completion] on a completion to select it.\n")))
3908 (insert (substitute-command-keys
3909 "In this buffer, type \\[choose-completion] to \
7d22ed15 3910select the completion near point.\n\n")))))
c88ab9ce 3911
e8a700bf 3912(add-hook 'completion-setup-hook 'completion-setup-function)
dde69dbe
RS
3913
3914(define-key minibuffer-local-completion-map [prior]
3915 'switch-to-completions)
3916(define-key minibuffer-local-must-match-map [prior]
3917 'switch-to-completions)
3918(define-key minibuffer-local-completion-map "\M-v"
3919 'switch-to-completions)
3920(define-key minibuffer-local-must-match-map "\M-v"
3921 'switch-to-completions)
3922
3923(defun switch-to-completions ()
3924 "Select the completion list window."
3925 (interactive)
9595fbdb
RS
3926 ;; Make sure we have a completions window.
3927 (or (get-buffer-window "*Completions*")
3928 (minibuffer-completion-help))
fdbd7c4d
KH
3929 (let ((window (get-buffer-window "*Completions*")))
3930 (when window
3931 (select-window window)
3932 (goto-char (point-min))
3933 (search-forward "\n\n")
3934 (forward-line 1))))
a3d1480b 3935\f
82072f33
RS
3936;; Support keyboard commands to turn on various modifiers.
3937
3938;; These functions -- which are not commands -- each add one modifier
3939;; to the following event.
3940
3941(defun event-apply-alt-modifier (ignore-prompt)
70cf9f08
KH
3942 "Add the Alt modifier to the following event.
3943For example, type \\[event-apply-alt-modifier] & to enter Alt-&."
82072f33
RS
3944 (vector (event-apply-modifier (read-event) 'alt 22 "A-")))
3945(defun event-apply-super-modifier (ignore-prompt)
70cf9f08
KH
3946 "Add the Super modifier to the following event.
3947For example, type \\[event-apply-super-modifier] & to enter Super-&."
82072f33
RS
3948 (vector (event-apply-modifier (read-event) 'super 23 "s-")))
3949(defun event-apply-hyper-modifier (ignore-prompt)
70cf9f08
KH
3950 "Add the Hyper modifier to the following event.
3951For example, type \\[event-apply-hyper-modifier] & to enter Hyper-&."
82072f33
RS
3952 (vector (event-apply-modifier (read-event) 'hyper 24 "H-")))
3953(defun event-apply-shift-modifier (ignore-prompt)
70cf9f08
KH
3954 "Add the Shift modifier to the following event.
3955For example, type \\[event-apply-shift-modifier] & to enter Shift-&."
82072f33
RS
3956 (vector (event-apply-modifier (read-event) 'shift 25 "S-")))
3957(defun event-apply-control-modifier (ignore-prompt)
70cf9f08
KH
3958 "Add the Ctrl modifier to the following event.
3959For example, type \\[event-apply-control-modifier] & to enter Ctrl-&."
82072f33
RS
3960 (vector (event-apply-modifier (read-event) 'control 26 "C-")))
3961(defun event-apply-meta-modifier (ignore-prompt)
70cf9f08
KH
3962 "Add the Meta modifier to the following event.
3963For example, type \\[event-apply-meta-modifier] & to enter Meta-&."
82072f33
RS
3964 (vector (event-apply-modifier (read-event) 'meta 27 "M-")))
3965
3966(defun event-apply-modifier (event symbol lshiftby prefix)
3967 "Apply a modifier flag to event EVENT.
3968SYMBOL is the name of this modifier, as a symbol.
3969LSHIFTBY is the numeric value of this modifier, in keyboard events.
3970PREFIX is the string that represents this modifier in an event type symbol."
3971 (if (numberp event)
3972 (cond ((eq symbol 'control)
90bebcb0
KH
3973 (if (and (<= (downcase event) ?z)
3974 (>= (downcase event) ?a))
82072f33 3975 (- (downcase event) ?a -1)
90bebcb0
KH
3976 (if (and (<= (downcase event) ?Z)
3977 (>= (downcase event) ?A))
82072f33
RS
3978 (- (downcase event) ?A -1)
3979 (logior (lsh 1 lshiftby) event))))
3980 ((eq symbol 'shift)
3981 (if (and (<= (downcase event) ?z)
3982 (>= (downcase event) ?a))
3983 (upcase event)
3984 (logior (lsh 1 lshiftby) event)))
3985 (t
3986 (logior (lsh 1 lshiftby) event)))
3987 (if (memq symbol (event-modifiers event))
3988 event
3989 (let ((event-type (if (symbolp event) event (car event))))
3990 (setq event-type (intern (concat prefix (symbol-name event-type))))
3991 (if (symbolp event)
3992 event-type
3993 (cons event-type (cdr event)))))))
3994
e5fff738
KH
3995(define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
3996(define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
3997(define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier)
3998(define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier)
3999(define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier)
4000(define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier)
82072f33 4001\f
a3d1480b
JB
4002;;;; Keypad support.
4003
4004;;; Make the keypad keys act like ordinary typing keys. If people add
4005;;; bindings for the function key symbols, then those bindings will
4006;;; override these, so this shouldn't interfere with any existing
4007;;; bindings.
4008
0d173134 4009;; Also tell read-char how to handle these keys.
a3d1480b
JB
4010(mapcar
4011 (lambda (keypad-normal)
4012 (let ((keypad (nth 0 keypad-normal))
4013 (normal (nth 1 keypad-normal)))
0d173134 4014 (put keypad 'ascii-character normal)
a3d1480b
JB
4015 (define-key function-key-map (vector keypad) (vector normal))))
4016 '((kp-0 ?0) (kp-1 ?1) (kp-2 ?2) (kp-3 ?3) (kp-4 ?4)
4017 (kp-5 ?5) (kp-6 ?6) (kp-7 ?7) (kp-8 ?8) (kp-9 ?9)
4018 (kp-space ?\ )
4019 (kp-tab ?\t)
4020 (kp-enter ?\r)
4021 (kp-multiply ?*)
4022 (kp-add ?+)
4023 (kp-separator ?,)
4024 (kp-subtract ?-)
4025 (kp-decimal ?.)
4026 (kp-divide ?/)
4027 (kp-equal ?=)))
4028
c88ab9ce 4029;;; simple.el ends here