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