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