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