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