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