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