Line data Source code
1 : ;;; simple.el --- basic editing commands for Emacs -*- lexical-binding: t -*-
2 :
3 : ;; Copyright (C) 1985-1987, 1993-2017 Free Software Foundation, Inc.
4 :
5 : ;; Maintainer: emacs-devel@gnu.org
6 : ;; Keywords: internal
7 : ;; Package: emacs
8 :
9 : ;; This file is part of GNU Emacs.
10 :
11 : ;; GNU Emacs is free software: you can redistribute it and/or modify
12 : ;; it under the terms of the GNU General Public License as published by
13 : ;; the Free Software Foundation, either version 3 of the License, or
14 : ;; (at your option) any later version.
15 :
16 : ;; GNU Emacs is distributed in the hope that it will be useful,
17 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 : ;; GNU General Public License for more details.
20 :
21 : ;; You should have received a copy of the GNU General Public License
22 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 :
24 : ;;; Commentary:
25 :
26 : ;; A grab-bag of basic Emacs commands not specifically related to some
27 : ;; major mode or to file-handling.
28 :
29 : ;;; Code:
30 :
31 : (eval-when-compile (require 'cl-lib))
32 :
33 : (declare-function widget-convert "wid-edit" (type &rest args))
34 : (declare-function shell-mode "shell" ())
35 :
36 : ;;; From compile.el
37 : (defvar compilation-current-error)
38 : (defvar compilation-context-lines)
39 :
40 : (defcustom shell-command-dont-erase-buffer nil
41 : "If non-nil, output buffer is not erased between shell commands.
42 : Also, a non-nil value set the point in the output buffer
43 : once the command complete.
44 : The value `beg-last-out' set point at the beginning of the output,
45 : `end-last-out' set point at the end of the buffer, `save-point'
46 : restore the buffer position before the command."
47 : :type '(choice
48 : (const :tag "Erase buffer" nil)
49 : (const :tag "Set point to beginning of last output" beg-last-out)
50 : (const :tag "Set point to end of last output" end-last-out)
51 : (const :tag "Save point" save-point))
52 : :group 'shell
53 : :version "26.1")
54 :
55 : (defvar shell-command-saved-pos nil
56 : "Point position in the output buffer after command complete.
57 : It is an alist (BUFFER . POS), where BUFFER is the output
58 : buffer, and POS is the point position in BUFFER once the command finish.
59 : This variable is used when `shell-command-dont-erase-buffer' is non-nil.")
60 :
61 : (defcustom idle-update-delay 0.5
62 : "Idle time delay before updating various things on the screen.
63 : Various Emacs features that update auxiliary information when point moves
64 : wait this many seconds after Emacs becomes idle before doing an update."
65 : :type 'number
66 : :group 'display
67 : :version "22.1")
68 :
69 : (defgroup killing nil
70 : "Killing and yanking commands."
71 : :group 'editing)
72 :
73 : (defgroup paren-matching nil
74 : "Highlight (un)matching of parens and expressions."
75 : :group 'matching)
76 :
77 : ;;; next-error support framework
78 :
79 : (defgroup next-error nil
80 : "`next-error' support framework."
81 : :group 'compilation
82 : :version "22.1")
83 :
84 : (defface next-error
85 : '((t (:inherit region)))
86 : "Face used to highlight next error locus."
87 : :group 'next-error
88 : :version "22.1")
89 :
90 : (defcustom next-error-highlight 0.5
91 : "Highlighting of locations in selected source buffers.
92 : If a number, highlight the locus in `next-error' face for the given time
93 : in seconds, or until the next command is executed.
94 : If t, highlight the locus until the next command is executed, or until
95 : some other locus replaces it.
96 : If nil, don't highlight the locus in the source buffer.
97 : If `fringe-arrow', indicate the locus by the fringe arrow
98 : indefinitely until some other locus replaces it."
99 : :type '(choice (number :tag "Highlight for specified time")
100 : (const :tag "Semipermanent highlighting" t)
101 : (const :tag "No highlighting" nil)
102 : (const :tag "Fringe arrow" fringe-arrow))
103 : :group 'next-error
104 : :version "22.1")
105 :
106 : (defcustom next-error-highlight-no-select 0.5
107 : "Highlighting of locations in `next-error-no-select'.
108 : If number, highlight the locus in `next-error' face for given time in seconds.
109 : If t, highlight the locus indefinitely until some other locus replaces it.
110 : If nil, don't highlight the locus in the source buffer.
111 : If `fringe-arrow', indicate the locus by the fringe arrow
112 : indefinitely until some other locus replaces it."
113 : :type '(choice (number :tag "Highlight for specified time")
114 : (const :tag "Semipermanent highlighting" t)
115 : (const :tag "No highlighting" nil)
116 : (const :tag "Fringe arrow" fringe-arrow))
117 : :group 'next-error
118 : :version "22.1")
119 :
120 : (defcustom next-error-recenter nil
121 : "Display the line in the visited source file recentered as specified.
122 : If non-nil, the value is passed directly to `recenter'."
123 : :type '(choice (integer :tag "Line to recenter to")
124 : (const :tag "Center of window" (4))
125 : (const :tag "No recentering" nil))
126 : :group 'next-error
127 : :version "23.1")
128 :
129 : (defcustom next-error-hook nil
130 : "List of hook functions run by `next-error' after visiting source file."
131 : :type 'hook
132 : :group 'next-error)
133 :
134 : (defvar next-error-highlight-timer nil)
135 :
136 : (defvar next-error-overlay-arrow-position nil)
137 : (put 'next-error-overlay-arrow-position 'overlay-arrow-string (purecopy "=>"))
138 : (add-to-list 'overlay-arrow-variable-list 'next-error-overlay-arrow-position)
139 :
140 : (defvar next-error-last-buffer nil
141 : "The most recent `next-error' buffer.
142 : A buffer becomes most recent when its compilation, grep, or
143 : similar mode is started, or when it is used with \\[next-error]
144 : or \\[compile-goto-error].")
145 :
146 : (defvar next-error-function nil
147 : "Function to use to find the next error in the current buffer.
148 : The function is called with 2 parameters:
149 : ARG is an integer specifying by how many errors to move.
150 : RESET is a boolean which, if non-nil, says to go back to the beginning
151 : of the errors before moving.
152 : Major modes providing compile-like functionality should set this variable
153 : to indicate to `next-error' that this is a candidate buffer and how
154 : to navigate in it.")
155 : (make-variable-buffer-local 'next-error-function)
156 :
157 : (defvar next-error-move-function nil
158 : "Function to use to move to an error locus.
159 : It takes two arguments, a buffer position in the error buffer
160 : and a buffer position in the error locus buffer.
161 : The buffer for the error locus should already be current.
162 : nil means use goto-char using the second argument position.")
163 : (make-variable-buffer-local 'next-error-move-function)
164 :
165 : (defsubst next-error-buffer-p (buffer
166 : &optional avoid-current
167 : extra-test-inclusive
168 : extra-test-exclusive)
169 : "Return non-nil if BUFFER is a `next-error' capable buffer.
170 : If AVOID-CURRENT is non-nil, and BUFFER is the current buffer,
171 : return nil.
172 :
173 : The function EXTRA-TEST-INCLUSIVE, if non-nil, is called if
174 : BUFFER would not normally qualify. If it returns non-nil, BUFFER
175 : is considered `next-error' capable, anyway, and the function
176 : returns non-nil.
177 :
178 : The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called if the
179 : buffer would normally qualify. If it returns nil, BUFFER is
180 : rejected, and the function returns nil."
181 0 : (and (buffer-name buffer) ;First make sure it's live.
182 0 : (not (and avoid-current (eq buffer (current-buffer))))
183 0 : (with-current-buffer buffer
184 0 : (if next-error-function ; This is the normal test.
185 : ;; Optionally reject some buffers.
186 0 : (if extra-test-exclusive
187 0 : (funcall extra-test-exclusive)
188 0 : t)
189 : ;; Optionally accept some other buffers.
190 0 : (and extra-test-inclusive
191 0 : (funcall extra-test-inclusive))))))
192 :
193 : (defun next-error-find-buffer (&optional avoid-current
194 : extra-test-inclusive
195 : extra-test-exclusive)
196 : "Return a `next-error' capable buffer.
197 :
198 : If AVOID-CURRENT is non-nil, treat the current buffer
199 : as an absolute last resort only.
200 :
201 : The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer
202 : that normally would not qualify. If it returns t, the buffer
203 : in question is treated as usable.
204 :
205 : The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called in each buffer
206 : that would normally be considered usable. If it returns nil,
207 : that buffer is rejected."
208 0 : (or
209 : ;; 1. If one window on the selected frame displays such buffer, return it.
210 0 : (let ((window-buffers
211 0 : (delete-dups
212 0 : (delq nil (mapcar (lambda (w)
213 0 : (if (next-error-buffer-p
214 0 : (window-buffer w)
215 0 : avoid-current
216 0 : extra-test-inclusive extra-test-exclusive)
217 0 : (window-buffer w)))
218 0 : (window-list))))))
219 0 : (if (eq (length window-buffers) 1)
220 0 : (car window-buffers)))
221 : ;; 2. If next-error-last-buffer is an acceptable buffer, use that.
222 0 : (if (and next-error-last-buffer
223 0 : (next-error-buffer-p next-error-last-buffer avoid-current
224 0 : extra-test-inclusive extra-test-exclusive))
225 0 : next-error-last-buffer)
226 : ;; 3. If the current buffer is acceptable, choose it.
227 0 : (if (next-error-buffer-p (current-buffer) avoid-current
228 0 : extra-test-inclusive extra-test-exclusive)
229 0 : (current-buffer))
230 : ;; 4. Look for any acceptable buffer.
231 0 : (let ((buffers (buffer-list)))
232 0 : (while (and buffers
233 0 : (not (next-error-buffer-p
234 0 : (car buffers) avoid-current
235 0 : extra-test-inclusive extra-test-exclusive)))
236 0 : (setq buffers (cdr buffers)))
237 0 : (car buffers))
238 : ;; 5. Use the current buffer as a last resort if it qualifies,
239 : ;; even despite AVOID-CURRENT.
240 0 : (and avoid-current
241 0 : (next-error-buffer-p (current-buffer) nil
242 0 : extra-test-inclusive extra-test-exclusive)
243 0 : (progn
244 0 : (message "This is the only buffer with error message locations")
245 0 : (current-buffer)))
246 : ;; 6. Give up.
247 0 : (error "No buffers contain error message locations")))
248 :
249 : (defun next-error (&optional arg reset)
250 : "Visit next `next-error' message and corresponding source code.
251 :
252 : If all the error messages parsed so far have been processed already,
253 : the message buffer is checked for new ones.
254 :
255 : A prefix ARG specifies how many error messages to move;
256 : negative means move back to previous error messages.
257 : Just \\[universal-argument] as a prefix means reparse the error message buffer
258 : and start at the first error.
259 :
260 : The RESET argument specifies that we should restart from the beginning.
261 :
262 : \\[next-error] normally uses the most recently started
263 : compilation, grep, or occur buffer. It can also operate on any
264 : buffer with output from the \\[compile], \\[grep] commands, or,
265 : more generally, on any buffer in Compilation mode or with
266 : Compilation Minor mode enabled, or any buffer in which
267 : `next-error-function' is bound to an appropriate function.
268 : To specify use of a particular buffer for error messages, type
269 : \\[next-error] in that buffer when it is the only one displayed
270 : in the current frame.
271 :
272 : Once \\[next-error] has chosen the buffer for error messages, it
273 : runs `next-error-hook' with `run-hooks', and stays with that buffer
274 : until you use it in some other buffer which uses Compilation mode
275 : or Compilation Minor mode.
276 :
277 : To control which errors are matched, customize the variable
278 : `compilation-error-regexp-alist'."
279 : (interactive "P")
280 0 : (if (consp arg) (setq reset t arg nil))
281 0 : (when (setq next-error-last-buffer (next-error-find-buffer))
282 : ;; we know here that next-error-function is a valid symbol we can funcall
283 0 : (with-current-buffer next-error-last-buffer
284 0 : (funcall next-error-function (prefix-numeric-value arg) reset)
285 0 : (when next-error-recenter
286 0 : (recenter next-error-recenter))
287 0 : (run-hooks 'next-error-hook))))
288 :
289 : (defun next-error-internal ()
290 : "Visit the source code corresponding to the `next-error' message at point."
291 0 : (setq next-error-last-buffer (current-buffer))
292 : ;; we know here that next-error-function is a valid symbol we can funcall
293 0 : (with-current-buffer next-error-last-buffer
294 0 : (funcall next-error-function 0 nil)
295 0 : (when next-error-recenter
296 0 : (recenter next-error-recenter))
297 0 : (run-hooks 'next-error-hook)))
298 :
299 : (defalias 'goto-next-locus 'next-error)
300 : (defalias 'next-match 'next-error)
301 :
302 : (defun previous-error (&optional n)
303 : "Visit previous `next-error' message and corresponding source code.
304 :
305 : Prefix arg N says how many error messages to move backwards (or
306 : forwards, if negative).
307 :
308 : This operates on the output from the \\[compile] and \\[grep] commands."
309 : (interactive "p")
310 0 : (next-error (- (or n 1))))
311 :
312 : (defun first-error (&optional n)
313 : "Restart at the first error.
314 : Visit corresponding source code.
315 : With prefix arg N, visit the source code of the Nth error.
316 : This operates on the output from the \\[compile] command, for instance."
317 : (interactive "p")
318 0 : (next-error n t))
319 :
320 : (defun next-error-no-select (&optional n)
321 : "Move point to the next error in the `next-error' buffer and highlight match.
322 : Prefix arg N says how many error messages to move forwards (or
323 : backwards, if negative).
324 : Finds and highlights the source line like \\[next-error], but does not
325 : select the source buffer."
326 : (interactive "p")
327 0 : (let ((next-error-highlight next-error-highlight-no-select))
328 0 : (next-error n))
329 0 : (pop-to-buffer next-error-last-buffer))
330 :
331 : (defun previous-error-no-select (&optional n)
332 : "Move point to the previous error in the `next-error' buffer and highlight match.
333 : Prefix arg N says how many error messages to move backwards (or
334 : forwards, if negative).
335 : Finds and highlights the source line like \\[previous-error], but does not
336 : select the source buffer."
337 : (interactive "p")
338 0 : (next-error-no-select (- (or n 1))))
339 :
340 : ;; Internal variable for `next-error-follow-mode-post-command-hook'.
341 : (defvar next-error-follow-last-line nil)
342 :
343 : (define-minor-mode next-error-follow-minor-mode
344 : "Minor mode for compilation, occur and diff modes.
345 : With a prefix argument ARG, enable mode if ARG is positive, and
346 : disable it otherwise. If called from Lisp, enable mode if ARG is
347 : omitted or nil.
348 : When turned on, cursor motion in the compilation, grep, occur or diff
349 : buffer causes automatic display of the corresponding source code location."
350 : :group 'next-error :init-value nil :lighter " Fol"
351 0 : (if (not next-error-follow-minor-mode)
352 0 : (remove-hook 'post-command-hook 'next-error-follow-mode-post-command-hook t)
353 0 : (add-hook 'post-command-hook 'next-error-follow-mode-post-command-hook nil t)
354 0 : (make-local-variable 'next-error-follow-last-line)))
355 :
356 : ;; Used as a `post-command-hook' by `next-error-follow-mode'
357 : ;; for the *Compilation* *grep* and *Occur* buffers.
358 : (defun next-error-follow-mode-post-command-hook ()
359 0 : (unless (equal next-error-follow-last-line (line-number-at-pos))
360 0 : (setq next-error-follow-last-line (line-number-at-pos))
361 0 : (condition-case nil
362 0 : (let ((compilation-context-lines nil))
363 0 : (setq compilation-current-error (point))
364 0 : (next-error-no-select 0))
365 0 : (error t))))
366 :
367 :
368 : ;;;
369 :
370 : (defun fundamental-mode ()
371 : "Major mode not specialized for anything in particular.
372 : Other major modes are defined by comparison with this one."
373 : (interactive)
374 0 : (kill-all-local-variables)
375 0 : (run-mode-hooks))
376 :
377 : ;; Special major modes to view specially formatted data rather than files.
378 :
379 : (defvar special-mode-map
380 : (let ((map (make-sparse-keymap)))
381 : (suppress-keymap map)
382 : (define-key map "q" 'quit-window)
383 : (define-key map " " 'scroll-up-command)
384 : (define-key map [?\S-\ ] 'scroll-down-command)
385 : (define-key map "\C-?" 'scroll-down-command)
386 : (define-key map "?" 'describe-mode)
387 : (define-key map "h" 'describe-mode)
388 : (define-key map ">" 'end-of-buffer)
389 : (define-key map "<" 'beginning-of-buffer)
390 : (define-key map "g" 'revert-buffer)
391 : map))
392 :
393 : (put 'special-mode 'mode-class 'special)
394 : (define-derived-mode special-mode nil "Special"
395 : "Parent major mode from which special major modes should inherit."
396 0 : (setq buffer-read-only t))
397 :
398 : ;; Making and deleting lines.
399 :
400 : (defvar self-insert-uses-region-functions nil
401 : "Special hook to tell if `self-insert-command' will use the region.
402 : It must be called via `run-hook-with-args-until-success' with no arguments.
403 : Any `post-self-insert-command' which consumes the region should
404 : register a function on this hook so that things like `delete-selection-mode'
405 : can refrain from consuming the region.")
406 :
407 : (defvar hard-newline (propertize "\n" 'hard t 'rear-nonsticky '(hard))
408 : "Propertized string representing a hard newline character.")
409 :
410 : (defun newline (&optional arg interactive)
411 : "Insert a newline, and move to left margin of the new line if it's blank.
412 : If option `use-hard-newlines' is non-nil, the newline is marked with the
413 : text-property `hard'.
414 : With ARG, insert that many newlines.
415 :
416 : If `electric-indent-mode' is enabled, this indents the final new line
417 : that it adds, and reindents the preceding line. To just insert
418 : a newline, use \\[electric-indent-just-newline].
419 :
420 : Calls `auto-fill-function' if the current column number is greater
421 : than the value of `fill-column' and ARG is nil.
422 : A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
423 : (interactive "*P\np")
424 404 : (barf-if-buffer-read-only)
425 : ;; Call self-insert so that auto-fill, abbrev expansion etc. happens.
426 : ;; Set last-command-event to tell self-insert what to insert.
427 404 : (let* ((was-page-start (and (bolp) (looking-at page-delimiter)))
428 404 : (beforepos (point))
429 : (last-command-event ?\n)
430 : ;; Don't auto-fill if we have a numeric argument.
431 404 : (auto-fill-function (if arg nil auto-fill-function))
432 404 : (arg (prefix-numeric-value arg))
433 : (postproc
434 : ;; Do the rest in post-self-insert-hook, because we want to do it
435 : ;; *before* other functions on that hook.
436 : (lambda ()
437 : ;; We are not going to insert any newlines if arg is
438 : ;; non-positive.
439 404 : (or (and (numberp arg) (<= arg 0))
440 404 : (cl-assert (eq ?\n (char-before))))
441 : ;; Mark the newline(s) `hard'.
442 404 : (if use-hard-newlines
443 0 : (set-hard-newline-properties
444 404 : (- (point) arg) (point)))
445 : ;; If the newline leaves the previous line blank, and we
446 : ;; have a left margin, delete that from the blank line.
447 404 : (save-excursion
448 404 : (goto-char beforepos)
449 404 : (beginning-of-line)
450 404 : (and (looking-at "[ \t]$")
451 0 : (> (current-left-margin) 0)
452 0 : (delete-region (point)
453 404 : (line-end-position))))
454 : ;; Indent the line after the newline, except in one case:
455 : ;; when we added the newline at the beginning of a line which
456 : ;; starts a page.
457 404 : (or was-page-start
458 404 : (move-to-left-margin nil t)))))
459 404 : (unwind-protect
460 404 : (if (not interactive)
461 : ;; FIXME: For non-interactive uses, many calls actually
462 : ;; just want (insert "\n"), so maybe we should do just
463 : ;; that, so as to avoid the risk of filling or running
464 : ;; abbrevs unexpectedly.
465 404 : (let ((post-self-insert-hook (list postproc)))
466 404 : (self-insert-command arg))
467 0 : (unwind-protect
468 0 : (progn
469 0 : (add-hook 'post-self-insert-hook postproc nil t)
470 0 : (self-insert-command arg))
471 : ;; We first used let-binding to protect the hook, but that
472 : ;; was naive since add-hook affects the symbol-default
473 : ;; value of the variable, whereas the let-binding might
474 : ;; only protect the buffer-local value.
475 404 : (remove-hook 'post-self-insert-hook postproc t)))
476 404 : (cl-assert (not (member postproc post-self-insert-hook)))
477 404 : (cl-assert (not (member postproc (default-value 'post-self-insert-hook))))))
478 : nil)
479 :
480 : (defun set-hard-newline-properties (from to)
481 0 : (let ((sticky (get-text-property from 'rear-nonsticky)))
482 0 : (put-text-property from to 'hard 't)
483 : ;; If rear-nonsticky is not "t", add 'hard to rear-nonsticky list
484 0 : (if (and (listp sticky) (not (memq 'hard sticky)))
485 0 : (put-text-property from (point) 'rear-nonsticky
486 0 : (cons 'hard sticky)))))
487 :
488 : (defun open-line (n)
489 : "Insert a newline and leave point before it.
490 : If there is a fill prefix and/or a `left-margin', insert them on
491 : the new line if the line would have been blank.
492 : With arg N, insert N newlines."
493 : (interactive "*p")
494 0 : (let* ((do-fill-prefix (and fill-prefix (bolp)))
495 0 : (do-left-margin (and (bolp) (> (current-left-margin) 0)))
496 0 : (loc (point-marker))
497 : ;; Don't expand an abbrev before point.
498 : (abbrev-mode nil))
499 0 : (newline n)
500 0 : (goto-char loc)
501 0 : (while (> n 0)
502 0 : (cond ((bolp)
503 0 : (if do-left-margin (indent-to (current-left-margin)))
504 0 : (if do-fill-prefix (insert-and-inherit fill-prefix))))
505 0 : (forward-line 1)
506 0 : (setq n (1- n)))
507 0 : (goto-char loc)
508 : ;; Necessary in case a margin or prefix was inserted.
509 0 : (end-of-line)))
510 :
511 : (defun split-line (&optional arg)
512 : "Split current line, moving portion beyond point vertically down.
513 : If the current line starts with `fill-prefix', insert it on the new
514 : line as well. With prefix ARG, don't insert `fill-prefix' on new line.
515 :
516 : When called from Lisp code, ARG may be a prefix string to copy."
517 : (interactive "*P")
518 0 : (skip-chars-forward " \t")
519 0 : (let* ((col (current-column))
520 0 : (pos (point))
521 : ;; What prefix should we check for (nil means don't).
522 0 : (prefix (cond ((stringp arg) arg)
523 0 : (arg nil)
524 0 : (t fill-prefix)))
525 : ;; Does this line start with it?
526 0 : (have-prfx (and prefix
527 0 : (save-excursion
528 0 : (beginning-of-line)
529 0 : (looking-at (regexp-quote prefix))))))
530 0 : (newline 1)
531 0 : (if have-prfx (insert-and-inherit prefix))
532 0 : (indent-to col 0)
533 0 : (goto-char pos)))
534 :
535 : (defun delete-indentation (&optional arg)
536 : "Join this line to previous and fix up whitespace at join.
537 : If there is a fill prefix, delete it from the beginning of this line.
538 : With argument, join this line to following line."
539 : (interactive "*P")
540 0 : (beginning-of-line)
541 0 : (if arg (forward-line 1))
542 0 : (if (eq (preceding-char) ?\n)
543 0 : (progn
544 0 : (delete-region (point) (1- (point)))
545 : ;; If the second line started with the fill prefix,
546 : ;; delete the prefix.
547 0 : (if (and fill-prefix
548 0 : (<= (+ (point) (length fill-prefix)) (point-max))
549 0 : (string= fill-prefix
550 0 : (buffer-substring (point)
551 0 : (+ (point) (length fill-prefix)))))
552 0 : (delete-region (point) (+ (point) (length fill-prefix))))
553 0 : (fixup-whitespace))))
554 :
555 : (defalias 'join-line #'delete-indentation) ; easier to find
556 :
557 : (defun delete-blank-lines ()
558 : "On blank line, delete all surrounding blank lines, leaving just one.
559 : On isolated blank line, delete that one.
560 : On nonblank line, delete any immediately following blank lines."
561 : (interactive "*")
562 0 : (let (thisblank singleblank)
563 0 : (save-excursion
564 0 : (beginning-of-line)
565 0 : (setq thisblank (looking-at "[ \t]*$"))
566 : ;; Set singleblank if there is just one blank line here.
567 0 : (setq singleblank
568 0 : (and thisblank
569 0 : (not (looking-at "[ \t]*\n[ \t]*$"))
570 0 : (or (bobp)
571 0 : (progn (forward-line -1)
572 0 : (not (looking-at "[ \t]*$")))))))
573 : ;; Delete preceding blank lines, and this one too if it's the only one.
574 0 : (if thisblank
575 0 : (progn
576 0 : (beginning-of-line)
577 0 : (if singleblank (forward-line 1))
578 0 : (delete-region (point)
579 0 : (if (re-search-backward "[^ \t\n]" nil t)
580 0 : (progn (forward-line 1) (point))
581 0 : (point-min)))))
582 : ;; Delete following blank lines, unless the current line is blank
583 : ;; and there are no following blank lines.
584 0 : (if (not (and thisblank singleblank))
585 0 : (save-excursion
586 0 : (end-of-line)
587 0 : (forward-line 1)
588 0 : (delete-region (point)
589 0 : (if (re-search-forward "[^ \t\n]" nil t)
590 0 : (progn (beginning-of-line) (point))
591 0 : (point-max)))))
592 : ;; Handle the special case where point is followed by newline and eob.
593 : ;; Delete the line, leaving point at eob.
594 0 : (if (looking-at "^[ \t]*\n\\'")
595 0 : (delete-region (point) (point-max)))))
596 :
597 : (defcustom delete-trailing-lines t
598 : "If non-nil, \\[delete-trailing-whitespace] deletes trailing lines.
599 : Trailing lines are deleted only if `delete-trailing-whitespace'
600 : is called on the entire buffer (rather than an active region)."
601 : :type 'boolean
602 : :group 'editing
603 : :version "24.3")
604 :
605 : (defun region-modifiable-p (start end)
606 : "Return non-nil if the region contains no read-only text."
607 0 : (and (not (get-text-property start 'read-only))
608 0 : (eq end (next-single-property-change start 'read-only nil end))))
609 :
610 : (defun delete-trailing-whitespace (&optional start end)
611 : "Delete trailing whitespace between START and END.
612 : If called interactively, START and END are the start/end of the
613 : region if the mark is active, or of the buffer's accessible
614 : portion if the mark is inactive.
615 :
616 : This command deletes whitespace characters after the last
617 : non-whitespace character in each line between START and END. It
618 : does not consider formfeed characters to be whitespace.
619 :
620 : If this command acts on the entire buffer (i.e. if called
621 : interactively with the mark inactive, or called from Lisp with
622 : END nil), it also deletes all trailing lines at the end of the
623 : buffer if the variable `delete-trailing-lines' is non-nil."
624 0 : (interactive (progn
625 0 : (barf-if-buffer-read-only)
626 0 : (if (use-region-p)
627 0 : (list (region-beginning) (region-end))
628 0 : (list nil nil))))
629 0 : (save-match-data
630 0 : (save-excursion
631 0 : (let ((end-marker (and end (copy-marker end))))
632 0 : (goto-char (or start (point-min)))
633 0 : (with-syntax-table (make-syntax-table (syntax-table))
634 : ;; Don't delete formfeeds, even if they are considered whitespace.
635 0 : (modify-syntax-entry ?\f "_")
636 0 : (while (re-search-forward "\\s-$" end-marker t)
637 0 : (skip-syntax-backward "-" (line-beginning-position))
638 0 : (let ((b (point)) (e (match-end 0)))
639 0 : (when (region-modifiable-p b e)
640 0 : (delete-region b e)))))
641 0 : (if end
642 0 : (set-marker end-marker nil)
643 : ;; Delete trailing empty lines.
644 0 : (and delete-trailing-lines
645 : ;; Really the end of buffer.
646 0 : (= (goto-char (point-max)) (1+ (buffer-size)))
647 0 : (<= (skip-chars-backward "\n") -2)
648 0 : (region-modifiable-p (1+ (point)) (point-max))
649 0 : (delete-region (1+ (point)) (point-max)))))))
650 : ;; Return nil for the benefit of `write-file-functions'.
651 : nil)
652 :
653 : (defun newline-and-indent ()
654 : "Insert a newline, then indent according to major mode.
655 : Indentation is done using the value of `indent-line-function'.
656 : In programming language modes, this is the same as TAB.
657 : In some text modes, where TAB inserts a tab, this command indents to the
658 : column specified by the function `current-left-margin'."
659 : (interactive "*")
660 0 : (delete-horizontal-space t)
661 0 : (newline nil t)
662 0 : (indent-according-to-mode))
663 :
664 : (defun reindent-then-newline-and-indent ()
665 : "Reindent current line, insert newline, then indent the new line.
666 : Indentation of both lines is done according to the current major mode,
667 : which means calling the current value of `indent-line-function'.
668 : In programming language modes, this is the same as TAB.
669 : In some text modes, where TAB inserts a tab, this indents to the
670 : column specified by the function `current-left-margin'."
671 : (interactive "*")
672 0 : (let ((pos (point)))
673 : ;; Be careful to insert the newline before indenting the line.
674 : ;; Otherwise, the indentation might be wrong.
675 0 : (newline)
676 0 : (save-excursion
677 0 : (goto-char pos)
678 : ;; We are at EOL before the call to indent-according-to-mode, and
679 : ;; after it we usually are as well, but not always. We tried to
680 : ;; address it with `save-excursion' but that uses a normal marker
681 : ;; whereas we need `move after insertion', so we do the save/restore
682 : ;; by hand.
683 0 : (setq pos (copy-marker pos t))
684 0 : (indent-according-to-mode)
685 0 : (goto-char pos)
686 : ;; Remove the trailing white-space after indentation because
687 : ;; indentation may introduce the whitespace.
688 0 : (delete-horizontal-space t))
689 0 : (indent-according-to-mode)))
690 :
691 : (defcustom read-quoted-char-radix 8
692 : "Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
693 : Legitimate radix values are 8, 10 and 16."
694 : :type '(choice (const 8) (const 10) (const 16))
695 : :group 'editing-basics)
696 :
697 : (defun read-quoted-char (&optional prompt)
698 : "Like `read-char', but do not allow quitting.
699 : Also, if the first character read is an octal digit,
700 : we read any number of octal digits and return the
701 : specified character code. Any nondigit terminates the sequence.
702 : If the terminator is RET, it is discarded;
703 : any other terminator is used itself as input.
704 :
705 : The optional argument PROMPT specifies a string to use to prompt the user.
706 : The variable `read-quoted-char-radix' controls which radix to use
707 : for numeric input."
708 0 : (let ((message-log-max nil)
709 0 : (help-events (delq nil (mapcar (lambda (c) (unless (characterp c) c))
710 0 : help-event-list)))
711 : done (first t) (code 0) char translated)
712 0 : (while (not done)
713 0 : (let ((inhibit-quit first)
714 : ;; Don't let C-h or other help chars get the help
715 : ;; message--only help function keys. See bug#16617.
716 : (help-char nil)
717 0 : (help-event-list help-events)
718 : (help-form
719 : "Type the special character you want to use,
720 : or the octal character code.
721 : RET terminates the character code and is discarded;
722 : any other non-digit terminates the character code and is then used as input."))
723 0 : (setq char (read-event (and prompt (format "%s-" prompt)) t))
724 0 : (if inhibit-quit (setq quit-flag nil)))
725 : ;; Translate TAB key into control-I ASCII character, and so on.
726 : ;; Note: `read-char' does it using the `ascii-character' property.
727 : ;; We tried using read-key instead, but that disables the keystroke
728 : ;; echo produced by 'C-q', see bug#24635.
729 0 : (let ((translation (lookup-key local-function-key-map (vector char))))
730 0 : (setq translated (if (arrayp translation)
731 0 : (aref translation 0)
732 0 : char)))
733 0 : (if (integerp translated)
734 0 : (setq translated (char-resolve-modifiers translated)))
735 0 : (cond ((null translated))
736 0 : ((not (integerp translated))
737 0 : (setq unread-command-events (list char)
738 0 : done t))
739 0 : ((/= (logand translated ?\M-\^@) 0)
740 : ;; Turn a meta-character into a character with the 0200 bit set.
741 0 : (setq code (logior (logand translated (lognot ?\M-\^@)) 128)
742 0 : done t))
743 0 : ((and (<= ?0 translated)
744 0 : (< translated (+ ?0 (min 10 read-quoted-char-radix))))
745 0 : (setq code (+ (* code read-quoted-char-radix) (- translated ?0)))
746 0 : (and prompt (setq prompt (message "%s %c" prompt translated))))
747 0 : ((and (<= ?a (downcase translated))
748 0 : (< (downcase translated)
749 0 : (+ ?a -10 (min 36 read-quoted-char-radix))))
750 0 : (setq code (+ (* code read-quoted-char-radix)
751 0 : (+ 10 (- (downcase translated) ?a))))
752 0 : (and prompt (setq prompt (message "%s %c" prompt translated))))
753 0 : ((and (not first) (eq translated ?\C-m))
754 0 : (setq done t))
755 0 : ((not first)
756 0 : (setq unread-command-events (list char)
757 0 : done t))
758 0 : (t (setq code translated
759 0 : done t)))
760 0 : (setq first nil))
761 0 : code))
762 :
763 : (defun quoted-insert (arg)
764 : "Read next input character and insert it.
765 : This is useful for inserting control characters.
766 : With argument, insert ARG copies of the character.
767 :
768 : If the first character you type after this command is an octal digit,
769 : you should type a sequence of octal digits which specify a character code.
770 : Any nondigit terminates the sequence. If the terminator is a RET,
771 : it is discarded; any other terminator is used itself as input.
772 : The variable `read-quoted-char-radix' specifies the radix for this feature;
773 : set it to 10 or 16 to use decimal or hex instead of octal.
774 :
775 : In overwrite mode, this function inserts the character anyway, and
776 : does not handle octal digits specially. This means that if you use
777 : overwrite as your normal editing mode, you can use this function to
778 : insert characters when necessary.
779 :
780 : In binary overwrite mode, this function does overwrite, and octal
781 : digits are interpreted as a character code. This is intended to be
782 : useful for editing binary files."
783 : (interactive "*p")
784 0 : (let* ((char
785 : ;; Avoid "obsolete" warnings for translation-table-for-input.
786 0 : (with-no-warnings
787 0 : (let (translation-table-for-input input-method-function)
788 0 : (if (or (not overwrite-mode)
789 0 : (eq overwrite-mode 'overwrite-mode-binary))
790 0 : (read-quoted-char)
791 0 : (read-char))))))
792 : ;; This used to assume character codes 0240 - 0377 stand for
793 : ;; characters in some single-byte character set, and converted them
794 : ;; to Emacs characters. But in 23.1 this feature is deprecated
795 : ;; in favor of inserting the corresponding Unicode characters.
796 : ;; (if (and enable-multibyte-characters
797 : ;; (>= char ?\240)
798 : ;; (<= char ?\377))
799 : ;; (setq char (unibyte-char-to-multibyte char)))
800 0 : (unless (characterp char)
801 0 : (user-error "%s is not a valid character"
802 0 : (key-description (vector char))))
803 0 : (if (> arg 0)
804 0 : (if (eq overwrite-mode 'overwrite-mode-binary)
805 0 : (delete-char arg)))
806 0 : (while (> arg 0)
807 0 : (insert-and-inherit char)
808 0 : (setq arg (1- arg)))))
809 :
810 : (defun forward-to-indentation (&optional arg)
811 : "Move forward ARG lines and position at first nonblank character."
812 : (interactive "^p")
813 0 : (forward-line (or arg 1))
814 0 : (skip-chars-forward " \t"))
815 :
816 : (defun backward-to-indentation (&optional arg)
817 : "Move backward ARG lines and position at first nonblank character."
818 : (interactive "^p")
819 0 : (forward-line (- (or arg 1)))
820 0 : (skip-chars-forward " \t"))
821 :
822 : (defun back-to-indentation ()
823 : "Move point to the first non-whitespace character on this line."
824 : (interactive "^")
825 404 : (beginning-of-line 1)
826 404 : (skip-syntax-forward " " (line-end-position))
827 : ;; Move back over chars that have whitespace syntax but have the p flag.
828 404 : (backward-prefix-chars))
829 :
830 : (defun fixup-whitespace ()
831 : "Fixup white space between objects around point.
832 : Leave one space or none, according to the context."
833 : (interactive "*")
834 0 : (save-excursion
835 0 : (delete-horizontal-space)
836 0 : (if (or (looking-at "^\\|$\\|\\s)")
837 0 : (save-excursion (forward-char -1)
838 0 : (looking-at "$\\|\\s(\\|\\s'")))
839 : nil
840 0 : (insert ?\s))))
841 :
842 : (defun delete-horizontal-space (&optional backward-only)
843 : "Delete all spaces and tabs around point.
844 : If BACKWARD-ONLY is non-nil, only delete them before point."
845 : (interactive "*P")
846 0 : (let ((orig-pos (point)))
847 0 : (delete-region
848 0 : (if backward-only
849 0 : orig-pos
850 0 : (progn
851 0 : (skip-chars-forward " \t")
852 0 : (constrain-to-field nil orig-pos t)))
853 0 : (progn
854 0 : (skip-chars-backward " \t")
855 0 : (constrain-to-field nil orig-pos)))))
856 :
857 : (defun just-one-space (&optional n)
858 : "Delete all spaces and tabs around point, leaving one space (or N spaces).
859 : If N is negative, delete newlines as well, leaving -N spaces.
860 : See also `cycle-spacing'."
861 : (interactive "*p")
862 0 : (cycle-spacing n nil 'single-shot))
863 :
864 : (defvar cycle-spacing--context nil
865 : "Store context used in consecutive calls to `cycle-spacing' command.
866 : The first time `cycle-spacing' runs, it saves in this variable:
867 : its N argument, the original point position, and the original spacing
868 : around point.")
869 :
870 : (defun cycle-spacing (&optional n preserve-nl-back mode)
871 : "Manipulate whitespace around point in a smart way.
872 : In interactive use, this function behaves differently in successive
873 : consecutive calls.
874 :
875 : The first call in a sequence acts like `just-one-space'.
876 : It deletes all spaces and tabs around point, leaving one space
877 : \(or N spaces). N is the prefix argument. If N is negative,
878 : it deletes newlines as well, leaving -N spaces.
879 : \(If PRESERVE-NL-BACK is non-nil, it does not delete newlines before point.)
880 :
881 : The second call in a sequence deletes all spaces.
882 :
883 : The third call in a sequence restores the original whitespace (and point).
884 :
885 : If MODE is `single-shot', it only performs the first step in the sequence.
886 : If MODE is `fast' and the first step would not result in any change
887 : \(i.e., there are exactly (abs N) spaces around point),
888 : the function goes straight to the second step.
889 :
890 : Repeatedly calling the function with different values of N starts a
891 : new sequence each time."
892 : (interactive "*p")
893 0 : (let ((orig-pos (point))
894 0 : (skip-characters (if (and n (< n 0)) " \t\n\r" " \t"))
895 0 : (num (abs (or n 1))))
896 0 : (skip-chars-backward (if preserve-nl-back " \t" skip-characters))
897 0 : (constrain-to-field nil orig-pos)
898 0 : (cond
899 : ;; Command run for the first time, single-shot mode or different argument
900 0 : ((or (eq 'single-shot mode)
901 0 : (not (equal last-command this-command))
902 0 : (not cycle-spacing--context)
903 0 : (not (eq (car cycle-spacing--context) n)))
904 0 : (let* ((start (point))
905 0 : (num (- num (skip-chars-forward " " (+ num (point)))))
906 0 : (mid (point))
907 0 : (end (progn
908 0 : (skip-chars-forward skip-characters)
909 0 : (constrain-to-field nil orig-pos t))))
910 0 : (setq cycle-spacing--context ;; Save for later.
911 : ;; Special handling for case where there was no space at all.
912 0 : (unless (= start end)
913 0 : (cons n (cons orig-pos (buffer-substring start (point))))))
914 : ;; If this run causes no change in buffer content, delete all spaces,
915 : ;; otherwise delete all excess spaces.
916 0 : (delete-region (if (and (eq mode 'fast) (zerop num) (= mid end))
917 0 : start mid) end)
918 0 : (insert (make-string num ?\s))))
919 :
920 : ;; Command run for the second time.
921 0 : ((not (equal orig-pos (point)))
922 0 : (delete-region (point) orig-pos))
923 :
924 : ;; Command run for the third time.
925 : (t
926 0 : (insert (cddr cycle-spacing--context))
927 0 : (goto-char (cadr cycle-spacing--context))
928 0 : (setq cycle-spacing--context nil)))))
929 :
930 : (defun beginning-of-buffer (&optional arg)
931 : "Move point to the beginning of the buffer.
932 : With numeric arg N, put point N/10 of the way from the beginning.
933 : If the buffer is narrowed, this command uses the beginning of the
934 : accessible part of the buffer.
935 :
936 : Push mark at previous position, unless either a \\[universal-argument] prefix
937 : is supplied, or Transient Mark mode is enabled and the mark is active."
938 : (declare (interactive-only "use `(goto-char (point-min))' instead."))
939 : (interactive "^P")
940 0 : (or (consp arg)
941 0 : (region-active-p)
942 0 : (push-mark))
943 0 : (let ((size (- (point-max) (point-min))))
944 0 : (goto-char (if (and arg (not (consp arg)))
945 0 : (+ (point-min)
946 0 : (if (> size 10000)
947 : ;; Avoid overflow for large buffer sizes!
948 0 : (* (prefix-numeric-value arg)
949 0 : (/ size 10))
950 0 : (/ (+ 10 (* size (prefix-numeric-value arg))) 10)))
951 0 : (point-min))))
952 0 : (if (and arg (not (consp arg))) (forward-line 1)))
953 :
954 : (defun end-of-buffer (&optional arg)
955 : "Move point to the end of the buffer.
956 : With numeric arg N, put point N/10 of the way from the end.
957 : If the buffer is narrowed, this command uses the end of the
958 : accessible part of the buffer.
959 :
960 : Push mark at previous position, unless either a \\[universal-argument] prefix
961 : is supplied, or Transient Mark mode is enabled and the mark is active."
962 : (declare (interactive-only "use `(goto-char (point-max))' instead."))
963 : (interactive "^P")
964 0 : (or (consp arg) (region-active-p) (push-mark))
965 0 : (let ((size (- (point-max) (point-min))))
966 0 : (goto-char (if (and arg (not (consp arg)))
967 0 : (- (point-max)
968 0 : (if (> size 10000)
969 : ;; Avoid overflow for large buffer sizes!
970 0 : (* (prefix-numeric-value arg)
971 0 : (/ size 10))
972 0 : (/ (* size (prefix-numeric-value arg)) 10)))
973 0 : (point-max))))
974 : ;; If we went to a place in the middle of the buffer,
975 : ;; adjust it to the beginning of a line.
976 0 : (cond ((and arg (not (consp arg))) (forward-line 1))
977 0 : ((and (eq (current-buffer) (window-buffer))
978 0 : (> (point) (window-end nil t)))
979 : ;; If the end of the buffer is not already on the screen,
980 : ;; then scroll specially to put it near, but not at, the bottom.
981 0 : (overlay-recenter (point))
982 0 : (recenter -3))))
983 :
984 : (defcustom delete-active-region t
985 : "Whether single-char deletion commands delete an active region.
986 : This has an effect only if Transient Mark mode is enabled, and
987 : affects `delete-forward-char' and `delete-backward-char', though
988 : not `delete-char'.
989 :
990 : If the value is the symbol `kill', the active region is killed
991 : instead of deleted."
992 : :type '(choice (const :tag "Delete active region" t)
993 : (const :tag "Kill active region" kill)
994 : (const :tag "Do ordinary deletion" nil))
995 : :group 'killing
996 : :version "24.1")
997 :
998 : (defvar region-extract-function
999 : (lambda (method)
1000 : (when (region-beginning)
1001 : (cond
1002 : ((eq method 'bounds)
1003 : (list (cons (region-beginning) (region-end))))
1004 : ((eq method 'delete-only)
1005 : (delete-region (region-beginning) (region-end)))
1006 : (t
1007 : (filter-buffer-substring (region-beginning) (region-end) method)))))
1008 : "Function to get the region's content.
1009 : Called with one argument METHOD.
1010 : If METHOD is `delete-only', then delete the region; the return value
1011 : is undefined. If METHOD is nil, then return the content as a string.
1012 : If METHOD is `bounds', then return the boundaries of the region
1013 : as a list of the form (START . END).
1014 : If METHOD is anything else, delete the region and return its content
1015 : as a string, after filtering it with `filter-buffer-substring', which
1016 : is called with METHOD as its 3rd argument.")
1017 :
1018 : (defvar region-insert-function
1019 : (lambda (lines)
1020 : (let ((first t))
1021 : (while lines
1022 : (or first
1023 : (insert ?\n))
1024 : (insert-for-yank (car lines))
1025 : (setq lines (cdr lines)
1026 : first nil))))
1027 : "Function to insert the region's content.
1028 : Called with one argument LINES.
1029 : Insert the region as a list of lines.")
1030 :
1031 : (defun delete-backward-char (n &optional killflag)
1032 : "Delete the previous N characters (following if N is negative).
1033 : If Transient Mark mode is enabled, the mark is active, and N is 1,
1034 : delete the text in the region and deactivate the mark instead.
1035 : To disable this, set option `delete-active-region' to nil.
1036 :
1037 : Optional second arg KILLFLAG, if non-nil, means to kill (save in
1038 : kill ring) instead of delete. Interactively, N is the prefix
1039 : arg, and KILLFLAG is set if N is explicitly specified.
1040 :
1041 : When killing, the killed text is filtered by
1042 : `filter-buffer-substring' before it is saved in the kill ring, so
1043 : the actual saved text might be different from what was killed.
1044 :
1045 : In Overwrite mode, single character backward deletion may replace
1046 : tabs with spaces so as to back over columns, unless point is at
1047 : the end of the line."
1048 : (declare (interactive-only delete-char))
1049 : (interactive "p\nP")
1050 0 : (unless (integerp n)
1051 0 : (signal 'wrong-type-argument (list 'integerp n)))
1052 0 : (cond ((and (use-region-p)
1053 0 : delete-active-region
1054 0 : (= n 1))
1055 : ;; If a region is active, kill or delete it.
1056 0 : (if (eq delete-active-region 'kill)
1057 0 : (kill-region (region-beginning) (region-end) 'region)
1058 0 : (funcall region-extract-function 'delete-only)))
1059 : ;; In Overwrite mode, maybe untabify while deleting
1060 0 : ((null (or (null overwrite-mode)
1061 0 : (<= n 0)
1062 0 : (memq (char-before) '(?\t ?\n))
1063 0 : (eobp)
1064 0 : (eq (char-after) ?\n)))
1065 0 : (let ((ocol (current-column)))
1066 0 : (delete-char (- n) killflag)
1067 0 : (save-excursion
1068 0 : (insert-char ?\s (- ocol (current-column)) nil))))
1069 : ;; Otherwise, do simple deletion.
1070 0 : (t (delete-char (- n) killflag))))
1071 :
1072 : (defun delete-forward-char (n &optional killflag)
1073 : "Delete the following N characters (previous if N is negative).
1074 : If Transient Mark mode is enabled, the mark is active, and N is 1,
1075 : delete the text in the region and deactivate the mark instead.
1076 : To disable this, set variable `delete-active-region' to nil.
1077 :
1078 : Optional second arg KILLFLAG non-nil means to kill (save in kill
1079 : ring) instead of delete. Interactively, N is the prefix arg, and
1080 : KILLFLAG is set if N was explicitly specified.
1081 :
1082 : When killing, the killed text is filtered by
1083 : `filter-buffer-substring' before it is saved in the kill ring, so
1084 : the actual saved text might be different from what was killed."
1085 : (declare (interactive-only delete-char))
1086 : (interactive "p\nP")
1087 0 : (unless (integerp n)
1088 0 : (signal 'wrong-type-argument (list 'integerp n)))
1089 0 : (cond ((and (use-region-p)
1090 0 : delete-active-region
1091 0 : (= n 1))
1092 : ;; If a region is active, kill or delete it.
1093 0 : (if (eq delete-active-region 'kill)
1094 0 : (kill-region (region-beginning) (region-end) 'region)
1095 0 : (funcall region-extract-function 'delete-only)))
1096 :
1097 : ;; Otherwise, do simple deletion.
1098 0 : (t (delete-char n killflag))))
1099 :
1100 : (defun mark-whole-buffer ()
1101 : "Put point at beginning and mark at end of buffer.
1102 : If narrowing is in effect, only uses the accessible part of the buffer.
1103 : You probably should not use this function in Lisp programs;
1104 : it is usually a mistake for a Lisp function to use any subroutine
1105 : that uses or sets the mark."
1106 : (declare (interactive-only t))
1107 : (interactive)
1108 0 : (push-mark)
1109 0 : (push-mark (point-max) nil t)
1110 : ;; This is really `point-min' in most cases, but if we're in the
1111 : ;; minibuffer, this is at the end of the prompt.
1112 0 : (goto-char (minibuffer-prompt-end)))
1113 :
1114 :
1115 : ;; Counting lines, one way or another.
1116 :
1117 : (defun goto-line (line &optional buffer)
1118 : "Go to LINE, counting from line 1 at beginning of buffer.
1119 : If called interactively, a numeric prefix argument specifies
1120 : LINE; without a numeric prefix argument, read LINE from the
1121 : minibuffer.
1122 :
1123 : If optional argument BUFFER is non-nil, switch to that buffer and
1124 : move to line LINE there. If called interactively with \\[universal-argument]
1125 : as argument, BUFFER is the most recently selected other buffer.
1126 :
1127 : Prior to moving point, this function sets the mark (without
1128 : activating it), unless Transient Mark mode is enabled and the
1129 : mark is already active.
1130 :
1131 : This function is usually the wrong thing to use in a Lisp program.
1132 : What you probably want instead is something like:
1133 : (goto-char (point-min))
1134 : (forward-line (1- N))
1135 : If at all possible, an even better solution is to use char counts
1136 : rather than line counts."
1137 : (declare (interactive-only forward-line))
1138 : (interactive
1139 0 : (if (and current-prefix-arg (not (consp current-prefix-arg)))
1140 0 : (list (prefix-numeric-value current-prefix-arg))
1141 : ;; Look for a default, a number in the buffer at point.
1142 0 : (let* ((default
1143 0 : (save-excursion
1144 0 : (skip-chars-backward "0-9")
1145 0 : (if (looking-at "[0-9]")
1146 0 : (string-to-number
1147 0 : (buffer-substring-no-properties
1148 0 : (point)
1149 0 : (progn (skip-chars-forward "0-9")
1150 0 : (point)))))))
1151 : ;; Decide if we're switching buffers.
1152 : (buffer
1153 0 : (if (consp current-prefix-arg)
1154 0 : (other-buffer (current-buffer) t)))
1155 : (buffer-prompt
1156 0 : (if buffer
1157 0 : (concat " in " (buffer-name buffer))
1158 0 : "")))
1159 : ;; Read the argument, offering that number (if any) as default.
1160 0 : (list (read-number (format "Goto line%s: " buffer-prompt)
1161 0 : (list default (line-number-at-pos)))
1162 0 : buffer))))
1163 : ;; Switch to the desired buffer, one way or another.
1164 0 : (if buffer
1165 0 : (let ((window (get-buffer-window buffer)))
1166 0 : (if window (select-window window)
1167 0 : (switch-to-buffer-other-window buffer))))
1168 : ;; Leave mark at previous position
1169 0 : (or (region-active-p) (push-mark))
1170 : ;; Move to the specified line number in that buffer.
1171 0 : (save-restriction
1172 0 : (widen)
1173 0 : (goto-char (point-min))
1174 0 : (if (eq selective-display t)
1175 0 : (re-search-forward "[\n\C-m]" nil 'end (1- line))
1176 0 : (forward-line (1- line)))))
1177 :
1178 : (defun count-words-region (start end &optional arg)
1179 : "Count the number of words in the region.
1180 : If called interactively, print a message reporting the number of
1181 : lines, words, and characters in the region (whether or not the
1182 : region is active); with prefix ARG, report for the entire buffer
1183 : rather than the region.
1184 :
1185 : If called from Lisp, return the number of words between positions
1186 : START and END."
1187 0 : (interactive (if current-prefix-arg
1188 0 : (list nil nil current-prefix-arg)
1189 0 : (list (region-beginning) (region-end) nil)))
1190 0 : (cond ((not (called-interactively-p 'any))
1191 0 : (count-words start end))
1192 0 : (arg
1193 0 : (count-words--buffer-message))
1194 : (t
1195 0 : (count-words--message "Region" start end))))
1196 :
1197 : (defun count-words (start end)
1198 : "Count words between START and END.
1199 : If called interactively, START and END are normally the start and
1200 : end of the buffer; but if the region is active, START and END are
1201 : the start and end of the region. Print a message reporting the
1202 : number of lines, words, and chars.
1203 :
1204 : If called from Lisp, return the number of words between START and
1205 : END, without printing any message."
1206 0 : (interactive (list nil nil))
1207 0 : (cond ((not (called-interactively-p 'any))
1208 0 : (let ((words 0))
1209 0 : (save-excursion
1210 0 : (save-restriction
1211 0 : (narrow-to-region start end)
1212 0 : (goto-char (point-min))
1213 0 : (while (forward-word-strictly 1)
1214 0 : (setq words (1+ words)))))
1215 0 : words))
1216 0 : ((use-region-p)
1217 0 : (call-interactively 'count-words-region))
1218 : (t
1219 0 : (count-words--buffer-message))))
1220 :
1221 : (defun count-words--buffer-message ()
1222 0 : (count-words--message
1223 0 : (if (buffer-narrowed-p) "Narrowed part of buffer" "Buffer")
1224 0 : (point-min) (point-max)))
1225 :
1226 : (defun count-words--message (str start end)
1227 0 : (let ((lines (count-lines start end))
1228 0 : (words (count-words start end))
1229 0 : (chars (- end start)))
1230 0 : (message "%s has %d line%s, %d word%s, and %d character%s."
1231 0 : str
1232 0 : lines (if (= lines 1) "" "s")
1233 0 : words (if (= words 1) "" "s")
1234 0 : chars (if (= chars 1) "" "s"))))
1235 :
1236 : (define-obsolete-function-alias 'count-lines-region 'count-words-region "24.1")
1237 :
1238 : (defun what-line ()
1239 : "Print the current buffer line number and narrowed line number of point."
1240 : (interactive)
1241 0 : (let ((start (point-min))
1242 0 : (n (line-number-at-pos)))
1243 0 : (if (= start 1)
1244 0 : (message "Line %d" n)
1245 0 : (save-excursion
1246 0 : (save-restriction
1247 0 : (widen)
1248 0 : (message "line %d (narrowed line %d)"
1249 0 : (+ n (line-number-at-pos start) -1) n))))))
1250 :
1251 : (defun count-lines (start end)
1252 : "Return number of lines between START and END.
1253 : This is usually the number of newlines between them,
1254 : but can be one more if START is not equal to END
1255 : and the greater of them is not at the start of a line."
1256 7158 : (save-excursion
1257 7158 : (save-restriction
1258 7158 : (narrow-to-region start end)
1259 7158 : (goto-char (point-min))
1260 7158 : (if (eq selective-display t)
1261 0 : (save-match-data
1262 0 : (let ((done 0))
1263 0 : (while (re-search-forward "[\n\C-m]" nil t 40)
1264 0 : (setq done (+ 40 done)))
1265 0 : (while (re-search-forward "[\n\C-m]" nil t 1)
1266 0 : (setq done (+ 1 done)))
1267 0 : (goto-char (point-max))
1268 0 : (if (and (/= start end)
1269 0 : (not (bolp)))
1270 0 : (1+ done)
1271 0 : done)))
1272 7158 : (- (buffer-size) (forward-line (buffer-size)))))))
1273 :
1274 : (defun line-number-at-pos (&optional pos absolute)
1275 : "Return buffer line number at position POS.
1276 : If POS is nil, use current buffer location.
1277 :
1278 : If ABSOLUTE is nil, the default, counting starts
1279 : at (point-min), so the value refers to the contents of the
1280 : accessible portion of the (potentially narrowed) buffer. If
1281 : ABSOLUTE is non-nil, ignore any narrowing and return the
1282 : absolute line number."
1283 7159 : (save-restriction
1284 7159 : (when absolute
1285 7159 : (widen))
1286 7159 : (let ((opoint (or pos (point))) start)
1287 7159 : (save-excursion
1288 7159 : (goto-char (point-min))
1289 7159 : (setq start (point))
1290 7159 : (goto-char opoint)
1291 7159 : (forward-line 0)
1292 7159 : (1+ (count-lines start (point)))))))
1293 :
1294 : (defun what-cursor-position (&optional detail)
1295 : "Print info on cursor position (on screen and within buffer).
1296 : Also describe the character after point, and give its character code
1297 : in octal, decimal and hex.
1298 :
1299 : For a non-ASCII multibyte character, also give its encoding in the
1300 : buffer's selected coding system if the coding system encodes the
1301 : character safely. If the character is encoded into one byte, that
1302 : code is shown in hex. If the character is encoded into more than one
1303 : byte, just \"...\" is shown.
1304 :
1305 : In addition, with prefix argument, show details about that character
1306 : in *Help* buffer. See also the command `describe-char'."
1307 : (interactive "P")
1308 0 : (let* ((char (following-char))
1309 : (bidi-fixer
1310 : ;; If the character is one of LRE, LRO, RLE, RLO, it will
1311 : ;; start a directional embedding, which could completely
1312 : ;; disrupt the rest of the line (e.g., RLO will display the
1313 : ;; rest of the line right-to-left). So we put an invisible
1314 : ;; PDF character after these characters, to end the
1315 : ;; embedding, which eliminates any effects on the rest of
1316 : ;; the line. For RLE and RLO we also append an invisible
1317 : ;; LRM, to avoid reordering the following numerical
1318 : ;; characters. For LRI/RLI/FSI we append a PDI.
1319 0 : (cond ((memq char '(?\x202a ?\x202d))
1320 0 : (propertize (string ?\x202c) 'invisible t))
1321 0 : ((memq char '(?\x202b ?\x202e))
1322 0 : (propertize (string ?\x202c ?\x200e) 'invisible t))
1323 0 : ((memq char '(?\x2066 ?\x2067 ?\x2068))
1324 0 : (propertize (string ?\x2069) 'invisible t))
1325 : ;; Strong right-to-left characters cause reordering of
1326 : ;; the following numerical characters which show the
1327 : ;; codepoint, so append LRM to countermand that.
1328 0 : ((memq (get-char-code-property char 'bidi-class) '(R AL))
1329 0 : (propertize (string ?\x200e) 'invisible t))
1330 : (t
1331 0 : "")))
1332 0 : (beg (point-min))
1333 0 : (end (point-max))
1334 0 : (pos (point))
1335 0 : (total (buffer-size))
1336 0 : (percent (round (* 100.0 (1- pos)) (max 1 total)))
1337 0 : (hscroll (if (= (window-hscroll) 0)
1338 : ""
1339 0 : (format " Hscroll=%d" (window-hscroll))))
1340 0 : (col (current-column)))
1341 0 : (if (= pos end)
1342 0 : (if (or (/= beg 1) (/= end (1+ total)))
1343 0 : (message "point=%d of %d (%d%%) <%d-%d> column=%d%s"
1344 0 : pos total percent beg end col hscroll)
1345 0 : (message "point=%d of %d (EOB) column=%d%s"
1346 0 : pos total col hscroll))
1347 0 : (let ((coding buffer-file-coding-system)
1348 : encoded encoding-msg display-prop under-display)
1349 0 : (if (or (not coding)
1350 0 : (eq (coding-system-type coding) t))
1351 0 : (setq coding (default-value 'buffer-file-coding-system)))
1352 0 : (if (eq (char-charset char) 'eight-bit)
1353 0 : (setq encoding-msg
1354 0 : (format "(%d, #o%o, #x%x, raw-byte)" char char char))
1355 : ;; Check if the character is displayed with some `display'
1356 : ;; text property. In that case, set under-display to the
1357 : ;; buffer substring covered by that property.
1358 0 : (setq display-prop (get-char-property pos 'display))
1359 0 : (if display-prop
1360 0 : (let ((to (or (next-single-char-property-change pos 'display)
1361 0 : (point-max))))
1362 0 : (if (< to (+ pos 4))
1363 0 : (setq under-display "")
1364 0 : (setq under-display "..."
1365 0 : to (+ pos 4)))
1366 0 : (setq under-display
1367 0 : (concat (buffer-substring-no-properties pos to)
1368 0 : under-display)))
1369 0 : (setq encoded (and (>= char 128) (encode-coding-char char coding))))
1370 0 : (setq encoding-msg
1371 0 : (if display-prop
1372 0 : (if (not (stringp display-prop))
1373 0 : (format "(%d, #o%o, #x%x, part of display \"%s\")"
1374 0 : char char char under-display)
1375 0 : (format "(%d, #o%o, #x%x, part of display \"%s\"->\"%s\")"
1376 0 : char char char under-display display-prop))
1377 0 : (if encoded
1378 0 : (format "(%d, #o%o, #x%x, file %s)"
1379 0 : char char char
1380 0 : (if (> (length encoded) 1)
1381 : "..."
1382 0 : (encoded-string-description encoded coding)))
1383 0 : (format "(%d, #o%o, #x%x)" char char char)))))
1384 0 : (if detail
1385 : ;; We show the detailed information about CHAR.
1386 0 : (describe-char (point)))
1387 0 : (if (or (/= beg 1) (/= end (1+ total)))
1388 0 : (message "Char: %s%s %s point=%d of %d (%d%%) <%d-%d> column=%d%s"
1389 0 : (if (< char 256)
1390 0 : (single-key-description char)
1391 0 : (buffer-substring-no-properties (point) (1+ (point))))
1392 0 : bidi-fixer
1393 0 : encoding-msg pos total percent beg end col hscroll)
1394 0 : (message "Char: %s%s %s point=%d of %d (%d%%) column=%d%s"
1395 0 : (if enable-multibyte-characters
1396 0 : (if (< char 128)
1397 0 : (single-key-description char)
1398 0 : (buffer-substring-no-properties (point) (1+ (point))))
1399 0 : (single-key-description char))
1400 0 : bidi-fixer encoding-msg pos total percent col hscroll))))))
1401 :
1402 : ;; Initialize read-expression-map. It is defined at C level.
1403 : (defvar read-expression-map
1404 : (let ((m (make-sparse-keymap)))
1405 : (define-key m "\M-\t" 'completion-at-point)
1406 : ;; Might as well bind TAB to completion, since inserting a TAB char is
1407 : ;; much too rarely useful.
1408 : (define-key m "\t" 'completion-at-point)
1409 : (set-keymap-parent m minibuffer-local-map)
1410 : m))
1411 :
1412 : (defun read-minibuffer (prompt &optional initial-contents)
1413 : "Return a Lisp object read using the minibuffer, unevaluated.
1414 : Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
1415 : is a string to insert in the minibuffer before reading.
1416 : \(INITIAL-CONTENTS can also be a cons of a string and an integer.
1417 : Such arguments are used as in `read-from-minibuffer'.)"
1418 : ;; Used for interactive spec `x'.
1419 0 : (read-from-minibuffer prompt initial-contents minibuffer-local-map
1420 0 : t 'minibuffer-history))
1421 :
1422 : (defun eval-minibuffer (prompt &optional initial-contents)
1423 : "Return value of Lisp expression read using the minibuffer.
1424 : Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
1425 : is a string to insert in the minibuffer before reading.
1426 : \(INITIAL-CONTENTS can also be a cons of a string and an integer.
1427 : Such arguments are used as in `read-from-minibuffer'.)"
1428 : ;; Used for interactive spec `X'.
1429 0 : (eval (read--expression prompt initial-contents)))
1430 :
1431 : (defvar minibuffer-completing-symbol nil
1432 : "Non-nil means completing a Lisp symbol in the minibuffer.")
1433 : (make-obsolete-variable 'minibuffer-completing-symbol nil "24.1" 'get)
1434 :
1435 : (defvar minibuffer-default nil
1436 : "The current default value or list of default values in the minibuffer.
1437 : The functions `read-from-minibuffer' and `completing-read' bind
1438 : this variable locally.")
1439 :
1440 : (defcustom eval-expression-print-level 4
1441 : "Value for `print-level' while printing value in `eval-expression'.
1442 : A value of nil means no limit."
1443 : :group 'lisp
1444 : :type '(choice (const :tag "No Limit" nil) integer)
1445 : :version "21.1")
1446 :
1447 : (defcustom eval-expression-print-length 12
1448 : "Value for `print-length' while printing value in `eval-expression'.
1449 : A value of nil means no limit."
1450 : :group 'lisp
1451 : :type '(choice (const :tag "No Limit" nil) integer)
1452 : :version "21.1")
1453 :
1454 : (defcustom eval-expression-debug-on-error t
1455 : "If non-nil set `debug-on-error' to t in `eval-expression'.
1456 : If nil, don't change the value of `debug-on-error'."
1457 : :group 'lisp
1458 : :type 'boolean
1459 : :version "21.1")
1460 :
1461 : (defcustom eval-expression-print-maximum-character 127
1462 : "The largest integer that will be displayed as a character.
1463 : This affects printing by `eval-expression' (via
1464 : `eval-expression-print-format')."
1465 : :group 'lisp
1466 : :type 'integer
1467 : :version "26.1")
1468 :
1469 : (defun eval-expression-print-format (value)
1470 : "If VALUE in an integer, return a specially formatted string.
1471 : This string will typically look like \" (#o1, #x1, ?\\C-a)\".
1472 : If VALUE is not an integer, nil is returned.
1473 : This function is used by commands like `eval-expression' that
1474 : display the result of expression evaluation."
1475 0 : (when (integerp value)
1476 0 : (let ((char-string
1477 0 : (and (characterp value)
1478 0 : (<= value eval-expression-print-maximum-character)
1479 0 : (char-displayable-p value)
1480 0 : (prin1-char value))))
1481 0 : (if char-string
1482 0 : (format " (#o%o, #x%x, %s)" value value char-string)
1483 0 : (format " (#o%o, #x%x)" value value)))))
1484 :
1485 : (defvar eval-expression-minibuffer-setup-hook nil
1486 : "Hook run by `eval-expression' when entering the minibuffer.")
1487 :
1488 : (defun read--expression (prompt &optional initial-contents)
1489 0 : (let ((minibuffer-completing-symbol t))
1490 0 : (minibuffer-with-setup-hook
1491 : (lambda ()
1492 : ;; FIXME: call emacs-lisp-mode?
1493 0 : (add-function :before-until (local 'eldoc-documentation-function)
1494 0 : #'elisp-eldoc-documentation-function)
1495 0 : (eldoc-mode 1)
1496 0 : (add-hook 'completion-at-point-functions
1497 0 : #'elisp-completion-at-point nil t)
1498 0 : (run-hooks 'eval-expression-minibuffer-setup-hook))
1499 0 : (read-from-minibuffer prompt initial-contents
1500 0 : read-expression-map t
1501 0 : 'read-expression-history))))
1502 :
1503 : (defun eval-expression-get-print-arguments (prefix-argument)
1504 : "Get arguments for commands that print an expression result.
1505 : Returns a list (INSERT-VALUE NO-TRUNCATE CHAR-PRINT-LIMIT)
1506 : based on PREFIX-ARG. This function determines the interpretation
1507 : of the prefix argument for `eval-expression' and
1508 : `eval-last-sexp'."
1509 0 : (let ((num (prefix-numeric-value prefix-argument)))
1510 0 : (list (not (memq prefix-argument '(- nil)))
1511 0 : (= num 0)
1512 0 : (cond ((not (memq prefix-argument '(0 -1 - nil))) nil)
1513 0 : ((= num -1) most-positive-fixnum)
1514 0 : (t eval-expression-print-maximum-character)))))
1515 :
1516 : ;; We define this, rather than making `eval' interactive,
1517 : ;; for the sake of completion of names like eval-region, eval-buffer.
1518 : (defun eval-expression (exp &optional insert-value no-truncate char-print-limit)
1519 : "Evaluate EXP and print value in the echo area.
1520 : When called interactively, read an Emacs Lisp expression and
1521 : evaluate it. Value is also consed on to front of the variable
1522 : `values'. Optional argument INSERT-VALUE non-nil (interactively,
1523 : with a non `-' prefix argument) means insert the result into the
1524 : current buffer instead of printing it in the echo area.
1525 :
1526 : Normally, this function truncates long output according to the
1527 : value of the variables `eval-expression-print-length' and
1528 : `eval-expression-print-level'. When NO-TRUNCATE is
1529 : non-nil (interactively, with a prefix argument of zero), however,
1530 : there is no such truncation.
1531 :
1532 : If the resulting value is an integer, and CHAR-PRINT-LIMIT is
1533 : non-nil (interactively, unless given a positive prefix argument)
1534 : it will be printed in several additional formats (octal,
1535 : hexadecimal, and character). The character format is only used
1536 : if the value is below CHAR-PRINT-LIMIT (interactively, if the
1537 : prefix argument is -1 or the value is below
1538 : `eval-expression-print-maximum-character').
1539 :
1540 : Runs the hook `eval-expression-minibuffer-setup-hook' on entering the
1541 : minibuffer.
1542 :
1543 : If `eval-expression-debug-on-error' is non-nil, which is the default,
1544 : this command arranges for all errors to enter the debugger."
1545 : (interactive
1546 0 : (cons (read--expression "Eval: ")
1547 0 : (eval-expression-get-print-arguments current-prefix-arg)))
1548 :
1549 0 : (if (null eval-expression-debug-on-error)
1550 0 : (push (eval exp lexical-binding) values)
1551 0 : (let ((old-value (make-symbol "t")) new-value)
1552 : ;; Bind debug-on-error to something unique so that we can
1553 : ;; detect when evalled code changes it.
1554 0 : (let ((debug-on-error old-value))
1555 0 : (push (eval (macroexpand-all exp) lexical-binding) values)
1556 0 : (setq new-value debug-on-error))
1557 : ;; If evalled code has changed the value of debug-on-error,
1558 : ;; propagate that change to the global binding.
1559 0 : (unless (eq old-value new-value)
1560 0 : (setq debug-on-error new-value))))
1561 :
1562 0 : (let ((print-length (unless no-truncate eval-expression-print-length))
1563 0 : (print-level (unless no-truncate eval-expression-print-level))
1564 0 : (eval-expression-print-maximum-character char-print-limit)
1565 : (deactivate-mark))
1566 0 : (let ((out (if insert-value (current-buffer) t)))
1567 0 : (prog1
1568 0 : (prin1 (car values) out)
1569 0 : (let ((str (and char-print-limit
1570 0 : (eval-expression-print-format (car values)))))
1571 0 : (when str (princ str out)))))))
1572 :
1573 : (defun edit-and-eval-command (prompt command)
1574 : "Prompting with PROMPT, let user edit COMMAND and eval result.
1575 : COMMAND is a Lisp expression. Let user edit that expression in
1576 : the minibuffer, then read and evaluate the result."
1577 0 : (let ((command
1578 0 : (let ((print-level nil)
1579 0 : (minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
1580 0 : (unwind-protect
1581 0 : (read-from-minibuffer prompt
1582 0 : (prin1-to-string command)
1583 0 : read-expression-map t
1584 0 : 'command-history)
1585 : ;; If command was added to command-history as a string,
1586 : ;; get rid of that. We want only evaluable expressions there.
1587 0 : (if (stringp (car command-history))
1588 0 : (setq command-history (cdr command-history)))))))
1589 :
1590 : ;; If command to be redone does not match front of history,
1591 : ;; add it to the history.
1592 0 : (or (equal command (car command-history))
1593 0 : (setq command-history (cons command command-history)))
1594 0 : (eval command)))
1595 :
1596 : (defun repeat-complex-command (arg)
1597 : "Edit and re-evaluate last complex command, or ARGth from last.
1598 : A complex command is one which used the minibuffer.
1599 : The command is placed in the minibuffer as a Lisp form for editing.
1600 : The result is executed, repeating the command as changed.
1601 : If the command has been changed or is not the most recent previous
1602 : command it is added to the front of the command history.
1603 : You can use the minibuffer history commands \
1604 : \\<minibuffer-local-map>\\[next-history-element] and \\[previous-history-element]
1605 : to get different commands to edit and resubmit."
1606 : (interactive "p")
1607 0 : (let ((elt (nth (1- arg) command-history))
1608 : newcmd)
1609 0 : (if elt
1610 0 : (progn
1611 0 : (setq newcmd
1612 0 : (let ((print-level nil)
1613 0 : (minibuffer-history-position arg)
1614 0 : (minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
1615 0 : (unwind-protect
1616 0 : (read-from-minibuffer
1617 0 : "Redo: " (prin1-to-string elt) read-expression-map t
1618 0 : (cons 'command-history arg))
1619 :
1620 : ;; If command was added to command-history as a
1621 : ;; string, get rid of that. We want only
1622 : ;; evaluable expressions there.
1623 0 : (if (stringp (car command-history))
1624 0 : (setq command-history (cdr command-history))))))
1625 :
1626 : ;; If command to be redone does not match front of history,
1627 : ;; add it to the history.
1628 0 : (or (equal newcmd (car command-history))
1629 0 : (setq command-history (cons newcmd command-history)))
1630 0 : (apply #'funcall-interactively
1631 0 : (car newcmd)
1632 0 : (mapcar (lambda (e) (eval e t)) (cdr newcmd))))
1633 0 : (if command-history
1634 0 : (error "Argument %d is beyond length of command history" arg)
1635 0 : (error "There are no previous complex commands to repeat")))))
1636 :
1637 :
1638 : (defvar extended-command-history nil)
1639 : (defvar execute-extended-command--last-typed nil)
1640 :
1641 : (defun read-extended-command ()
1642 : "Read command name to invoke in `execute-extended-command'."
1643 0 : (minibuffer-with-setup-hook
1644 : (lambda ()
1645 0 : (add-hook 'post-self-insert-hook
1646 : (lambda ()
1647 0 : (setq execute-extended-command--last-typed
1648 0 : (minibuffer-contents)))
1649 0 : nil 'local)
1650 0 : (set (make-local-variable 'minibuffer-default-add-function)
1651 : (lambda ()
1652 : ;; Get a command name at point in the original buffer
1653 : ;; to propose it after M-n.
1654 0 : (with-current-buffer (window-buffer (minibuffer-selected-window))
1655 0 : (and (commandp (function-called-at-point))
1656 0 : (format "%S" (function-called-at-point)))))))
1657 : ;; Read a string, completing from and restricting to the set of
1658 : ;; all defined commands. Don't provide any initial input.
1659 : ;; Save the command read on the extended-command history list.
1660 0 : (completing-read
1661 0 : (concat (cond
1662 0 : ((eq current-prefix-arg '-) "- ")
1663 0 : ((and (consp current-prefix-arg)
1664 0 : (eq (car current-prefix-arg) 4)) "C-u ")
1665 0 : ((and (consp current-prefix-arg)
1666 0 : (integerp (car current-prefix-arg)))
1667 0 : (format "%d " (car current-prefix-arg)))
1668 0 : ((integerp current-prefix-arg)
1669 0 : (format "%d " current-prefix-arg)))
1670 : ;; This isn't strictly correct if `execute-extended-command'
1671 : ;; is bound to anything else (e.g. [menu]).
1672 : ;; It could use (key-description (this-single-command-keys)),
1673 : ;; but actually a prompt other than "M-x" would be confusing,
1674 : ;; because "M-x" is a well-known prompt to read a command
1675 : ;; and it serves as a shorthand for "Extended command: ".
1676 0 : "M-x ")
1677 : (lambda (string pred action)
1678 0 : (let ((pred
1679 0 : (if (memq action '(nil t))
1680 : ;; Exclude obsolete commands from completions.
1681 : (lambda (sym)
1682 0 : (and (funcall pred sym)
1683 0 : (or (equal string (symbol-name sym))
1684 0 : (not (get sym 'byte-obsolete-info)))))
1685 0 : pred)))
1686 0 : (complete-with-action action obarray string pred)))
1687 0 : #'commandp t nil 'extended-command-history)))
1688 :
1689 : (defcustom suggest-key-bindings t
1690 : "Non-nil means show the equivalent key-binding when M-x command has one.
1691 : The value can be a length of time to show the message for.
1692 : If the value is non-nil and not a number, we wait 2 seconds."
1693 : :group 'keyboard
1694 : :type '(choice (const :tag "off" nil)
1695 : (integer :tag "time" 2)
1696 : (other :tag "on")))
1697 :
1698 : (defcustom extended-command-suggest-shorter t
1699 : "If non-nil, show a shorter M-x invocation when there is one."
1700 : :group 'keyboard
1701 : :type 'boolean
1702 : :version "26.1")
1703 :
1704 : (defun execute-extended-command--shorter-1 (name length)
1705 0 : (cond
1706 0 : ((zerop length) (list ""))
1707 0 : ((equal name "") nil)
1708 : (t
1709 0 : (nconc (mapcar (lambda (s) (concat (substring name 0 1) s))
1710 0 : (execute-extended-command--shorter-1
1711 0 : (substring name 1) (1- length)))
1712 0 : (when (string-match "\\`\\(-\\)?[^-]*" name)
1713 0 : (execute-extended-command--shorter-1
1714 0 : (substring name (match-end 0)) length))))))
1715 :
1716 : (defun execute-extended-command--shorter (name typed)
1717 0 : (let ((candidates '())
1718 0 : (max (length typed))
1719 : (len 1)
1720 : binding)
1721 0 : (while (and (not binding)
1722 0 : (progn
1723 0 : (unless candidates
1724 0 : (setq len (1+ len))
1725 0 : (setq candidates (execute-extended-command--shorter-1
1726 0 : name len)))
1727 : ;; Don't show the help message if the binding isn't
1728 : ;; significantly shorter than the M-x command the user typed.
1729 0 : (< len (- max 5))))
1730 0 : (input-pending-p) ;Dummy call to trigger input-processing, bug#23002.
1731 0 : (let ((candidate (pop candidates)))
1732 0 : (when (equal name
1733 0 : (car-safe (completion-try-completion
1734 0 : candidate obarray 'commandp len)))
1735 0 : (setq binding candidate))))
1736 0 : binding))
1737 :
1738 : (defun execute-extended-command (prefixarg &optional command-name typed)
1739 : ;; Based on Fexecute_extended_command in keyboard.c of Emacs.
1740 : ;; Aaron S. Hawley <aaron.s.hawley(at)gmail.com> 2009-08-24
1741 : "Read a command name, then read the arguments and call the command.
1742 : To pass a prefix argument to the command you are
1743 : invoking, give a prefix argument to `execute-extended-command'."
1744 : (declare (interactive-only command-execute))
1745 : ;; FIXME: Remember the actual text typed by the user before completion,
1746 : ;; so that we don't later on suggest the same shortening.
1747 : (interactive
1748 0 : (let ((execute-extended-command--last-typed nil))
1749 0 : (list current-prefix-arg
1750 0 : (read-extended-command)
1751 0 : execute-extended-command--last-typed)))
1752 : ;; Emacs<24 calling-convention was with a single `prefixarg' argument.
1753 0 : (unless command-name
1754 0 : (let ((current-prefix-arg prefixarg) ; for prompt
1755 : (execute-extended-command--last-typed nil))
1756 0 : (setq command-name (read-extended-command))
1757 0 : (setq typed execute-extended-command--last-typed)))
1758 0 : (let* ((function (and (stringp command-name) (intern-soft command-name)))
1759 0 : (binding (and suggest-key-bindings
1760 0 : (not executing-kbd-macro)
1761 0 : (where-is-internal function overriding-local-map t))))
1762 0 : (unless (commandp function)
1763 0 : (error "`%s' is not a valid command name" command-name))
1764 : ;; Some features, such as novice.el, rely on this-command-keys
1765 : ;; including M-x COMMAND-NAME RET.
1766 0 : (set--this-command-keys (concat "\M-x" (symbol-name function) "\r"))
1767 0 : (setq this-command function)
1768 : ;; Normally `real-this-command' should never be changed, but here we really
1769 : ;; want to pretend that M-x <cmd> RET is nothing more than a "key
1770 : ;; binding" for <cmd>, so the command the user really wanted to run is
1771 : ;; `function' and not `execute-extended-command'. The difference is
1772 : ;; visible in cases such as M-x <cmd> RET and then C-x z (bug#11506).
1773 0 : (setq real-this-command function)
1774 0 : (let ((prefix-arg prefixarg))
1775 0 : (command-execute function 'record))
1776 : ;; If enabled, show which key runs this command.
1777 : ;; But first wait, and skip the message if there is input.
1778 0 : (let* ((waited
1779 : ;; If this command displayed something in the echo area;
1780 : ;; wait a few seconds, then display our suggestion message.
1781 : ;; FIXME: Wait *after* running post-command-hook!
1782 : ;; FIXME: Don't wait if execute-extended-command--shorter won't
1783 : ;; find a better answer anyway!
1784 0 : (when suggest-key-bindings
1785 0 : (sit-for (cond
1786 0 : ((zerop (length (current-message))) 0)
1787 0 : ((numberp suggest-key-bindings) suggest-key-bindings)
1788 0 : (t 2))))))
1789 0 : (when (and waited (not (consp unread-command-events)))
1790 0 : (unless (or (not extended-command-suggest-shorter)
1791 0 : binding executing-kbd-macro (not (symbolp function))
1792 0 : (<= (length (symbol-name function)) 2))
1793 : ;; There's no binding for CMD. Let's try and find the shortest
1794 : ;; string to use in M-x.
1795 : ;; FIXME: Can be slow. Cache it maybe?
1796 0 : (while-no-input
1797 0 : (setq binding (execute-extended-command--shorter
1798 0 : (symbol-name function) typed))))
1799 0 : (when binding
1800 0 : (with-temp-message
1801 0 : (format-message "You can run the command `%s' with %s"
1802 0 : function
1803 0 : (if (stringp binding)
1804 0 : (concat "M-x " binding " RET")
1805 0 : (key-description binding)))
1806 0 : (sit-for (if (numberp suggest-key-bindings)
1807 0 : suggest-key-bindings
1808 0 : 2))))))))
1809 :
1810 : (defun command-execute (cmd &optional record-flag keys special)
1811 : ;; BEWARE: Called directly from the C code.
1812 : "Execute CMD as an editor command.
1813 : CMD must be a symbol that satisfies the `commandp' predicate.
1814 : Optional second arg RECORD-FLAG non-nil
1815 : means unconditionally put this command in the variable `command-history'.
1816 : Otherwise, that is done only if an arg is read using the minibuffer.
1817 : The argument KEYS specifies the value to use instead of (this-command-keys)
1818 : when reading the arguments; if it is nil, (this-command-keys) is used.
1819 : The argument SPECIAL, if non-nil, means that this command is executing
1820 : a special event, so ignore the prefix argument and don't clear it."
1821 2 : (setq debug-on-next-call nil)
1822 2 : (let ((prefixarg (unless special
1823 : ;; FIXME: This should probably be done around
1824 : ;; pre-command-hook rather than here!
1825 0 : (prog1 prefix-arg
1826 0 : (setq current-prefix-arg prefix-arg)
1827 0 : (setq prefix-arg nil)
1828 0 : (when current-prefix-arg
1829 2 : (prefix-command-update))))))
1830 2 : (if (and (symbolp cmd)
1831 2 : (get cmd 'disabled)
1832 2 : disabled-command-function)
1833 : ;; FIXME: Weird calling convention!
1834 0 : (run-hooks 'disabled-command-function)
1835 2 : (let ((final cmd))
1836 2 : (while
1837 2 : (progn
1838 2 : (setq final (indirect-function final))
1839 2 : (if (autoloadp final)
1840 2 : (setq final (autoload-do-load final cmd)))))
1841 2 : (cond
1842 2 : ((arrayp final)
1843 : ;; If requested, place the macro in the command history. For
1844 : ;; other sorts of commands, call-interactively takes care of this.
1845 0 : (when record-flag
1846 0 : (push `(execute-kbd-macro ,final ,prefixarg) command-history)
1847 : ;; Don't keep command history around forever.
1848 0 : (when (and (numberp history-length) (> history-length 0))
1849 0 : (let ((cell (nthcdr history-length command-history)))
1850 0 : (if (consp cell) (setcdr cell nil)))))
1851 0 : (execute-kbd-macro final prefixarg))
1852 : (t
1853 : ;; Pass `cmd' rather than `final', for the backtrace's sake.
1854 2 : (prog1 (call-interactively cmd record-flag keys)
1855 2 : (when (and (symbolp cmd)
1856 2 : (get cmd 'byte-obsolete-info)
1857 2 : (not (get cmd 'command-execute-obsolete-warned)))
1858 0 : (put cmd 'command-execute-obsolete-warned t)
1859 0 : (message "%s" (macroexp--obsolete-warning
1860 2 : cmd (get cmd 'byte-obsolete-info) "command"))))))))))
1861 :
1862 : (defvar minibuffer-history nil
1863 : "Default minibuffer history list.
1864 : This is used for all minibuffer input
1865 : except when an alternate history list is specified.
1866 :
1867 : Maximum length of the history list is determined by the value
1868 : of `history-length', which see.")
1869 : (defvar minibuffer-history-sexp-flag nil
1870 : "Control whether history list elements are expressions or strings.
1871 : If the value of this variable equals current minibuffer depth,
1872 : they are expressions; otherwise they are strings.
1873 : \(That convention is designed to do the right thing for
1874 : recursive uses of the minibuffer.)")
1875 : (setq minibuffer-history-variable 'minibuffer-history)
1876 : (setq minibuffer-history-position nil) ;; Defvar is in C code.
1877 : (defvar minibuffer-history-search-history nil)
1878 :
1879 : (defvar minibuffer-text-before-history nil
1880 : "Text that was in this minibuffer before any history commands.
1881 : This is nil if there have not yet been any history commands
1882 : in this use of the minibuffer.")
1883 :
1884 : (add-hook 'minibuffer-setup-hook 'minibuffer-history-initialize)
1885 :
1886 : (defun minibuffer-history-initialize ()
1887 0 : (setq minibuffer-text-before-history nil))
1888 :
1889 : (defun minibuffer-avoid-prompt (_new _old)
1890 : "A point-motion hook for the minibuffer, that moves point out of the prompt."
1891 : (declare (obsolete cursor-intangible-mode "25.1"))
1892 0 : (constrain-to-field nil (point-max)))
1893 :
1894 : (defcustom minibuffer-history-case-insensitive-variables nil
1895 : "Minibuffer history variables for which matching should ignore case.
1896 : If a history variable is a member of this list, then the
1897 : \\[previous-matching-history-element] and \\[next-matching-history-element]\
1898 : commands ignore case when searching it, regardless of `case-fold-search'."
1899 : :type '(repeat variable)
1900 : :group 'minibuffer)
1901 :
1902 : (defun previous-matching-history-element (regexp n)
1903 : "Find the previous history element that matches REGEXP.
1904 : \(Previous history elements refer to earlier actions.)
1905 : With prefix argument N, search for Nth previous match.
1906 : If N is negative, find the next or Nth next match.
1907 : Normally, history elements are matched case-insensitively if
1908 : `case-fold-search' is non-nil, but an uppercase letter in REGEXP
1909 : makes the search case-sensitive.
1910 : See also `minibuffer-history-case-insensitive-variables'."
1911 : (interactive
1912 0 : (let* ((enable-recursive-minibuffers t)
1913 0 : (regexp (read-from-minibuffer "Previous element matching (regexp): "
1914 : nil
1915 0 : minibuffer-local-map
1916 : nil
1917 : 'minibuffer-history-search-history
1918 0 : (car minibuffer-history-search-history))))
1919 : ;; Use the last regexp specified, by default, if input is empty.
1920 0 : (list (if (string= regexp "")
1921 0 : (if minibuffer-history-search-history
1922 0 : (car minibuffer-history-search-history)
1923 0 : (user-error "No previous history search regexp"))
1924 0 : regexp)
1925 0 : (prefix-numeric-value current-prefix-arg))))
1926 0 : (unless (zerop n)
1927 0 : (if (and (zerop minibuffer-history-position)
1928 0 : (null minibuffer-text-before-history))
1929 0 : (setq minibuffer-text-before-history
1930 0 : (minibuffer-contents-no-properties)))
1931 0 : (let ((history (symbol-value minibuffer-history-variable))
1932 : (case-fold-search
1933 0 : (if (isearch-no-upper-case-p regexp t) ; assume isearch.el is dumped
1934 : ;; On some systems, ignore case for file names.
1935 0 : (if (memq minibuffer-history-variable
1936 0 : minibuffer-history-case-insensitive-variables)
1937 : t
1938 : ;; Respect the user's setting for case-fold-search:
1939 0 : case-fold-search)
1940 0 : nil))
1941 : prevpos
1942 : match-string
1943 : match-offset
1944 0 : (pos minibuffer-history-position))
1945 0 : (while (/= n 0)
1946 0 : (setq prevpos pos)
1947 0 : (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history)))
1948 0 : (when (= pos prevpos)
1949 0 : (user-error (if (= pos 1)
1950 : "No later matching history item"
1951 0 : "No earlier matching history item")))
1952 0 : (setq match-string
1953 0 : (if (eq minibuffer-history-sexp-flag (minibuffer-depth))
1954 0 : (let ((print-level nil))
1955 0 : (prin1-to-string (nth (1- pos) history)))
1956 0 : (nth (1- pos) history)))
1957 0 : (setq match-offset
1958 0 : (if (< n 0)
1959 0 : (and (string-match regexp match-string)
1960 0 : (match-end 0))
1961 0 : (and (string-match (concat ".*\\(" regexp "\\)") match-string)
1962 0 : (match-beginning 1))))
1963 0 : (when match-offset
1964 0 : (setq n (+ n (if (< n 0) 1 -1)))))
1965 0 : (setq minibuffer-history-position pos)
1966 0 : (goto-char (point-max))
1967 0 : (delete-minibuffer-contents)
1968 0 : (insert match-string)
1969 0 : (goto-char (+ (minibuffer-prompt-end) match-offset))))
1970 0 : (if (memq (car (car command-history)) '(previous-matching-history-element
1971 0 : next-matching-history-element))
1972 0 : (setq command-history (cdr command-history))))
1973 :
1974 : (defun next-matching-history-element (regexp n)
1975 : "Find the next history element that matches REGEXP.
1976 : \(The next history element refers to a more recent action.)
1977 : With prefix argument N, search for Nth next match.
1978 : If N is negative, find the previous or Nth previous match.
1979 : Normally, history elements are matched case-insensitively if
1980 : `case-fold-search' is non-nil, but an uppercase letter in REGEXP
1981 : makes the search case-sensitive."
1982 : (interactive
1983 0 : (let* ((enable-recursive-minibuffers t)
1984 0 : (regexp (read-from-minibuffer "Next element matching (regexp): "
1985 : nil
1986 0 : minibuffer-local-map
1987 : nil
1988 : 'minibuffer-history-search-history
1989 0 : (car minibuffer-history-search-history))))
1990 : ;; Use the last regexp specified, by default, if input is empty.
1991 0 : (list (if (string= regexp "")
1992 0 : (if minibuffer-history-search-history
1993 0 : (car minibuffer-history-search-history)
1994 0 : (user-error "No previous history search regexp"))
1995 0 : regexp)
1996 0 : (prefix-numeric-value current-prefix-arg))))
1997 0 : (previous-matching-history-element regexp (- n)))
1998 :
1999 : (defvar minibuffer-temporary-goal-position nil)
2000 :
2001 : (defvar minibuffer-default-add-function 'minibuffer-default-add-completions
2002 : "Function run by `goto-history-element' before consuming default values.
2003 : This is useful to dynamically add more elements to the list of default values
2004 : when `goto-history-element' reaches the end of this list.
2005 : Before calling this function `goto-history-element' sets the variable
2006 : `minibuffer-default-add-done' to t, so it will call this function only
2007 : once. In special cases, when this function needs to be called more
2008 : than once, it can set `minibuffer-default-add-done' to nil explicitly,
2009 : overriding the setting of this variable to t in `goto-history-element'.")
2010 :
2011 : (defvar minibuffer-default-add-done nil
2012 : "When nil, add more elements to the end of the list of default values.
2013 : The value nil causes `goto-history-element' to add more elements to
2014 : the list of defaults when it reaches the end of this list. It does
2015 : this by calling a function defined by `minibuffer-default-add-function'.")
2016 :
2017 : (make-variable-buffer-local 'minibuffer-default-add-done)
2018 :
2019 : (defun minibuffer-default-add-completions ()
2020 : "Return a list of all completions without the default value.
2021 : This function is used to add all elements of the completion table to
2022 : the end of the list of defaults just after the default value."
2023 0 : (let ((def minibuffer-default)
2024 0 : (all (all-completions ""
2025 0 : minibuffer-completion-table
2026 0 : minibuffer-completion-predicate)))
2027 0 : (if (listp def)
2028 0 : (append def all)
2029 0 : (cons def (delete def all)))))
2030 :
2031 : (defun goto-history-element (nabs)
2032 : "Puts element of the minibuffer history in the minibuffer.
2033 : The argument NABS specifies the absolute history position."
2034 : (interactive "p")
2035 0 : (when (and (not minibuffer-default-add-done)
2036 0 : (functionp minibuffer-default-add-function)
2037 0 : (< nabs (- (if (listp minibuffer-default)
2038 0 : (length minibuffer-default)
2039 0 : 1))))
2040 0 : (setq minibuffer-default-add-done t
2041 0 : minibuffer-default (funcall minibuffer-default-add-function)))
2042 0 : (let ((minimum (if minibuffer-default
2043 0 : (- (if (listp minibuffer-default)
2044 0 : (length minibuffer-default)
2045 0 : 1))
2046 0 : 0))
2047 : elt minibuffer-returned-to-present)
2048 0 : (if (and (zerop minibuffer-history-position)
2049 0 : (null minibuffer-text-before-history))
2050 0 : (setq minibuffer-text-before-history
2051 0 : (minibuffer-contents-no-properties)))
2052 0 : (if (< nabs minimum)
2053 0 : (user-error (if minibuffer-default
2054 : "End of defaults; no next item"
2055 0 : "End of history; no default available")))
2056 0 : (if (> nabs (if (listp (symbol-value minibuffer-history-variable))
2057 0 : (length (symbol-value minibuffer-history-variable))
2058 0 : 0))
2059 0 : (user-error "Beginning of history; no preceding item"))
2060 0 : (unless (memq last-command '(next-history-element
2061 0 : previous-history-element))
2062 0 : (let ((prompt-end (minibuffer-prompt-end)))
2063 0 : (set (make-local-variable 'minibuffer-temporary-goal-position)
2064 0 : (cond ((<= (point) prompt-end) prompt-end)
2065 0 : ((eobp) nil)
2066 0 : (t (point))))))
2067 0 : (goto-char (point-max))
2068 0 : (delete-minibuffer-contents)
2069 0 : (setq minibuffer-history-position nabs)
2070 0 : (cond ((< nabs 0)
2071 0 : (setq elt (if (listp minibuffer-default)
2072 0 : (nth (1- (abs nabs)) minibuffer-default)
2073 0 : minibuffer-default)))
2074 0 : ((= nabs 0)
2075 0 : (setq elt (or minibuffer-text-before-history ""))
2076 0 : (setq minibuffer-returned-to-present t)
2077 0 : (setq minibuffer-text-before-history nil))
2078 0 : (t (setq elt (nth (1- minibuffer-history-position)
2079 0 : (symbol-value minibuffer-history-variable)))))
2080 0 : (insert
2081 0 : (if (and (eq minibuffer-history-sexp-flag (minibuffer-depth))
2082 0 : (not minibuffer-returned-to-present))
2083 0 : (let ((print-level nil))
2084 0 : (prin1-to-string elt))
2085 0 : elt))
2086 0 : (goto-char (or minibuffer-temporary-goal-position (point-max)))))
2087 :
2088 : (defun next-history-element (n)
2089 : "Puts next element of the minibuffer history in the minibuffer.
2090 : With argument N, it uses the Nth following element."
2091 : (interactive "p")
2092 0 : (or (zerop n)
2093 0 : (goto-history-element (- minibuffer-history-position n))))
2094 :
2095 : (defun previous-history-element (n)
2096 : "Puts previous element of the minibuffer history in the minibuffer.
2097 : With argument N, it uses the Nth previous element."
2098 : (interactive "p")
2099 0 : (or (zerop n)
2100 0 : (goto-history-element (+ minibuffer-history-position n))))
2101 :
2102 : (defun next-line-or-history-element (&optional arg)
2103 : "Move cursor vertically down ARG lines, or to the next history element.
2104 : When point moves over the bottom line of multi-line minibuffer, puts ARGth
2105 : next element of the minibuffer history in the minibuffer."
2106 : (interactive "^p")
2107 0 : (or arg (setq arg 1))
2108 0 : (let* ((old-point (point))
2109 : ;; Remember the original goal column of possibly multi-line input
2110 : ;; excluding the length of the prompt on the first line.
2111 0 : (prompt-end (minibuffer-prompt-end))
2112 0 : (old-column (unless (and (eolp) (> (point) prompt-end))
2113 0 : (if (= (line-number-at-pos) 1)
2114 0 : (max (- (current-column) (1- prompt-end)) 0)
2115 0 : (current-column)))))
2116 0 : (condition-case nil
2117 0 : (with-no-warnings
2118 0 : (next-line arg))
2119 : (end-of-buffer
2120 : ;; Restore old position since `line-move-visual' moves point to
2121 : ;; the end of the line when it fails to go to the next line.
2122 0 : (goto-char old-point)
2123 0 : (next-history-element arg)
2124 : ;; Reset `temporary-goal-column' because a correct value is not
2125 : ;; calculated when `next-line' above fails by bumping against
2126 : ;; the bottom of the minibuffer (bug#22544).
2127 0 : (setq temporary-goal-column 0)
2128 : ;; Restore the original goal column on the last line
2129 : ;; of possibly multi-line input.
2130 0 : (goto-char (point-max))
2131 0 : (when old-column
2132 0 : (if (= (line-number-at-pos) 1)
2133 0 : (move-to-column (+ old-column (1- (minibuffer-prompt-end))))
2134 0 : (move-to-column old-column)))))))
2135 :
2136 : (defun previous-line-or-history-element (&optional arg)
2137 : "Move cursor vertically up ARG lines, or to the previous history element.
2138 : When point moves over the top line of multi-line minibuffer, puts ARGth
2139 : previous element of the minibuffer history in the minibuffer."
2140 : (interactive "^p")
2141 0 : (or arg (setq arg 1))
2142 0 : (let* ((old-point (point))
2143 : ;; Remember the original goal column of possibly multi-line input
2144 : ;; excluding the length of the prompt on the first line.
2145 0 : (prompt-end (minibuffer-prompt-end))
2146 0 : (old-column (unless (and (eolp) (> (point) prompt-end))
2147 0 : (if (= (line-number-at-pos) 1)
2148 0 : (max (- (current-column) (1- prompt-end)) 0)
2149 0 : (current-column)))))
2150 0 : (condition-case nil
2151 0 : (with-no-warnings
2152 0 : (previous-line arg))
2153 : (beginning-of-buffer
2154 : ;; Restore old position since `line-move-visual' moves point to
2155 : ;; the beginning of the line when it fails to go to the previous line.
2156 0 : (goto-char old-point)
2157 0 : (previous-history-element arg)
2158 : ;; Reset `temporary-goal-column' because a correct value is not
2159 : ;; calculated when `previous-line' above fails by bumping against
2160 : ;; the top of the minibuffer (bug#22544).
2161 0 : (setq temporary-goal-column 0)
2162 : ;; Restore the original goal column on the first line
2163 : ;; of possibly multi-line input.
2164 0 : (goto-char (minibuffer-prompt-end))
2165 0 : (if old-column
2166 0 : (if (= (line-number-at-pos) 1)
2167 0 : (move-to-column (+ old-column (1- (minibuffer-prompt-end))))
2168 0 : (move-to-column old-column))
2169 : ;; Put the cursor at the end of the visual line instead of the
2170 : ;; logical line, so the next `previous-line-or-history-element'
2171 : ;; would move to the previous history element, not to a possible upper
2172 : ;; visual line from the end of logical line in `line-move-visual' mode.
2173 0 : (end-of-visual-line)
2174 : ;; Since `end-of-visual-line' puts the cursor at the beginning
2175 : ;; of the next visual line, move it one char back to the end
2176 : ;; of the first visual line (bug#22544).
2177 0 : (unless (eolp) (backward-char 1)))))))
2178 :
2179 : (defun next-complete-history-element (n)
2180 : "Get next history element which completes the minibuffer before the point.
2181 : The contents of the minibuffer after the point are deleted, and replaced
2182 : by the new completion."
2183 : (interactive "p")
2184 0 : (let ((point-at-start (point)))
2185 0 : (next-matching-history-element
2186 0 : (concat
2187 0 : "^" (regexp-quote (buffer-substring (minibuffer-prompt-end) (point))))
2188 0 : n)
2189 : ;; next-matching-history-element always puts us at (point-min).
2190 : ;; Move to the position we were at before changing the buffer contents.
2191 : ;; This is still sensible, because the text before point has not changed.
2192 0 : (goto-char point-at-start)))
2193 :
2194 : (defun previous-complete-history-element (n)
2195 : "\
2196 : Get previous history element which completes the minibuffer before the point.
2197 : The contents of the minibuffer after the point are deleted, and replaced
2198 : by the new completion."
2199 : (interactive "p")
2200 0 : (next-complete-history-element (- n)))
2201 :
2202 : ;; For compatibility with the old subr of the same name.
2203 : (defun minibuffer-prompt-width ()
2204 : "Return the display width of the minibuffer prompt.
2205 : Return 0 if current buffer is not a minibuffer."
2206 : ;; Return the width of everything before the field at the end of
2207 : ;; the buffer; this should be 0 for normal buffers.
2208 0 : (1- (minibuffer-prompt-end)))
2209 :
2210 : ;; isearch minibuffer history
2211 : (add-hook 'minibuffer-setup-hook 'minibuffer-history-isearch-setup)
2212 :
2213 : (defvar minibuffer-history-isearch-message-overlay)
2214 : (make-variable-buffer-local 'minibuffer-history-isearch-message-overlay)
2215 :
2216 : (defun minibuffer-history-isearch-setup ()
2217 : "Set up a minibuffer for using isearch to search the minibuffer history.
2218 : Intended to be added to `minibuffer-setup-hook'."
2219 0 : (set (make-local-variable 'isearch-search-fun-function)
2220 0 : 'minibuffer-history-isearch-search)
2221 0 : (set (make-local-variable 'isearch-message-function)
2222 0 : 'minibuffer-history-isearch-message)
2223 0 : (set (make-local-variable 'isearch-wrap-function)
2224 0 : 'minibuffer-history-isearch-wrap)
2225 0 : (set (make-local-variable 'isearch-push-state-function)
2226 0 : 'minibuffer-history-isearch-push-state)
2227 0 : (add-hook 'isearch-mode-end-hook 'minibuffer-history-isearch-end nil t))
2228 :
2229 : (defun minibuffer-history-isearch-end ()
2230 : "Clean up the minibuffer after terminating isearch in the minibuffer."
2231 0 : (if minibuffer-history-isearch-message-overlay
2232 0 : (delete-overlay minibuffer-history-isearch-message-overlay)))
2233 :
2234 : (defun minibuffer-history-isearch-search ()
2235 : "Return the proper search function, for isearch in minibuffer history."
2236 : (lambda (string bound noerror)
2237 0 : (let ((search-fun
2238 : ;; Use standard functions to search within minibuffer text
2239 0 : (isearch-search-fun-default))
2240 : found)
2241 : ;; Avoid lazy-highlighting matches in the minibuffer prompt when
2242 : ;; searching forward. Lazy-highlight calls this lambda with the
2243 : ;; bound arg, so skip the minibuffer prompt.
2244 0 : (if (and bound isearch-forward (< (point) (minibuffer-prompt-end)))
2245 0 : (goto-char (minibuffer-prompt-end)))
2246 0 : (or
2247 : ;; 1. First try searching in the initial minibuffer text
2248 0 : (funcall search-fun string
2249 0 : (if isearch-forward bound (minibuffer-prompt-end))
2250 0 : noerror)
2251 : ;; 2. If the above search fails, start putting next/prev history
2252 : ;; elements in the minibuffer successively, and search the string
2253 : ;; in them. Do this only when bound is nil (i.e. not while
2254 : ;; lazy-highlighting search strings in the current minibuffer text).
2255 0 : (unless bound
2256 0 : (condition-case nil
2257 0 : (progn
2258 0 : (while (not found)
2259 0 : (cond (isearch-forward
2260 0 : (next-history-element 1)
2261 0 : (goto-char (minibuffer-prompt-end)))
2262 : (t
2263 0 : (previous-history-element 1)
2264 0 : (goto-char (point-max))))
2265 0 : (setq isearch-barrier (point) isearch-opoint (point))
2266 : ;; After putting the next/prev history element, search
2267 : ;; the string in them again, until next-history-element
2268 : ;; or previous-history-element raises an error at the
2269 : ;; beginning/end of history.
2270 0 : (setq found (funcall search-fun string
2271 0 : (unless isearch-forward
2272 : ;; For backward search, don't search
2273 : ;; in the minibuffer prompt
2274 0 : (minibuffer-prompt-end))
2275 0 : noerror)))
2276 : ;; Return point of the new search result
2277 0 : (point))
2278 : ;; Return nil when next(prev)-history-element fails
2279 0 : (error nil)))))))
2280 :
2281 : (defun minibuffer-history-isearch-message (&optional c-q-hack ellipsis)
2282 : "Display the minibuffer history search prompt.
2283 : If there are no search errors, this function displays an overlay with
2284 : the isearch prompt which replaces the original minibuffer prompt.
2285 : Otherwise, it displays the standard isearch message returned from
2286 : the function `isearch-message'."
2287 0 : (if (not (and (minibufferp) isearch-success (not isearch-error)))
2288 : ;; Use standard function `isearch-message' when not in the minibuffer,
2289 : ;; or search fails, or has an error (like incomplete regexp).
2290 : ;; This function overwrites minibuffer text with isearch message,
2291 : ;; so it's possible to see what is wrong in the search string.
2292 0 : (isearch-message c-q-hack ellipsis)
2293 : ;; Otherwise, put the overlay with the standard isearch prompt over
2294 : ;; the initial minibuffer prompt.
2295 0 : (if (overlayp minibuffer-history-isearch-message-overlay)
2296 0 : (move-overlay minibuffer-history-isearch-message-overlay
2297 0 : (point-min) (minibuffer-prompt-end))
2298 0 : (setq minibuffer-history-isearch-message-overlay
2299 0 : (make-overlay (point-min) (minibuffer-prompt-end)))
2300 0 : (overlay-put minibuffer-history-isearch-message-overlay 'evaporate t))
2301 0 : (overlay-put minibuffer-history-isearch-message-overlay
2302 0 : 'display (isearch-message-prefix c-q-hack ellipsis))
2303 : ;; And clear any previous isearch message.
2304 0 : (message "")))
2305 :
2306 : (defun minibuffer-history-isearch-wrap ()
2307 : "Wrap the minibuffer history search when search fails.
2308 : Move point to the first history element for a forward search,
2309 : or to the last history element for a backward search."
2310 : ;; When `minibuffer-history-isearch-search' fails on reaching the
2311 : ;; beginning/end of the history, wrap the search to the first/last
2312 : ;; minibuffer history element.
2313 0 : (if isearch-forward
2314 0 : (goto-history-element (length (symbol-value minibuffer-history-variable)))
2315 0 : (goto-history-element 0))
2316 0 : (setq isearch-success t)
2317 0 : (goto-char (if isearch-forward (minibuffer-prompt-end) (point-max))))
2318 :
2319 : (defun minibuffer-history-isearch-push-state ()
2320 : "Save a function restoring the state of minibuffer history search.
2321 : Save `minibuffer-history-position' to the additional state parameter
2322 : in the search status stack."
2323 0 : (let ((pos minibuffer-history-position))
2324 : (lambda (cmd)
2325 0 : (minibuffer-history-isearch-pop-state cmd pos))))
2326 :
2327 : (defun minibuffer-history-isearch-pop-state (_cmd hist-pos)
2328 : "Restore the minibuffer history search state.
2329 : Go to the history element by the absolute history position HIST-POS."
2330 0 : (goto-history-element hist-pos))
2331 :
2332 :
2333 : ;Put this on C-x u, so we can force that rather than C-_ into startup msg
2334 : (define-obsolete-function-alias 'advertised-undo 'undo "23.2")
2335 :
2336 : (defconst undo-equiv-table (make-hash-table :test 'eq :weakness t)
2337 : "Table mapping redo records to the corresponding undo one.
2338 : A redo record for undo-in-region maps to t.
2339 : A redo record for ordinary undo maps to the following (earlier) undo.")
2340 :
2341 : (defvar undo-in-region nil
2342 : "Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.")
2343 :
2344 : (defvar undo-no-redo nil
2345 : "If t, `undo' doesn't go through redo entries.")
2346 :
2347 : (defvar pending-undo-list nil
2348 : "Within a run of consecutive undo commands, list remaining to be undone.
2349 : If t, we undid all the way to the end of it.")
2350 :
2351 : (defun undo (&optional arg)
2352 : "Undo some previous changes.
2353 : Repeat this command to undo more changes.
2354 : A numeric ARG serves as a repeat count.
2355 :
2356 : In Transient Mark mode when the mark is active, only undo changes within
2357 : the current region. Similarly, when not in Transient Mark mode, just \\[universal-argument]
2358 : as an argument limits undo to changes within the current region."
2359 : (interactive "*P")
2360 : ;; Make last-command indicate for the next command that this was an undo.
2361 : ;; That way, another undo will undo more.
2362 : ;; If we get to the end of the undo history and get an error,
2363 : ;; another undo command will find the undo history empty
2364 : ;; and will get another error. To begin undoing the undos,
2365 : ;; you must type some other command.
2366 0 : (let* ((modified (buffer-modified-p))
2367 : ;; For an indirect buffer, look in the base buffer for the
2368 : ;; auto-save data.
2369 0 : (base-buffer (or (buffer-base-buffer) (current-buffer)))
2370 0 : (recent-save (with-current-buffer base-buffer
2371 0 : (recent-auto-save-p)))
2372 : message)
2373 : ;; If we get an error in undo-start,
2374 : ;; the next command should not be a "consecutive undo".
2375 : ;; So set `this-command' to something other than `undo'.
2376 0 : (setq this-command 'undo-start)
2377 :
2378 0 : (unless (and (eq last-command 'undo)
2379 0 : (or (eq pending-undo-list t)
2380 : ;; If something (a timer or filter?) changed the buffer
2381 : ;; since the previous command, don't continue the undo seq.
2382 0 : (let ((list buffer-undo-list))
2383 0 : (while (eq (car list) nil)
2384 0 : (setq list (cdr list)))
2385 : ;; If the last undo record made was made by undo
2386 : ;; it shows nothing else happened in between.
2387 0 : (gethash list undo-equiv-table))))
2388 0 : (setq undo-in-region
2389 0 : (or (region-active-p) (and arg (not (numberp arg)))))
2390 0 : (if undo-in-region
2391 0 : (undo-start (region-beginning) (region-end))
2392 0 : (undo-start))
2393 : ;; get rid of initial undo boundary
2394 0 : (undo-more 1))
2395 : ;; If we got this far, the next command should be a consecutive undo.
2396 0 : (setq this-command 'undo)
2397 : ;; Check to see whether we're hitting a redo record, and if
2398 : ;; so, ask the user whether she wants to skip the redo/undo pair.
2399 0 : (let ((equiv (gethash pending-undo-list undo-equiv-table)))
2400 0 : (or (eq (selected-window) (minibuffer-window))
2401 0 : (setq message (format "%s%s!"
2402 0 : (if (or undo-no-redo (not equiv))
2403 0 : "Undo" "Redo")
2404 0 : (if undo-in-region " in region" ""))))
2405 0 : (when (and (consp equiv) undo-no-redo)
2406 : ;; The equiv entry might point to another redo record if we have done
2407 : ;; undo-redo-undo-redo-... so skip to the very last equiv.
2408 0 : (while (let ((next (gethash equiv undo-equiv-table)))
2409 0 : (if next (setq equiv next))))
2410 0 : (setq pending-undo-list equiv)))
2411 0 : (undo-more
2412 0 : (if (numberp arg)
2413 0 : (prefix-numeric-value arg)
2414 0 : 1))
2415 : ;; Record the fact that the just-generated undo records come from an
2416 : ;; undo operation--that is, they are redo records.
2417 : ;; In the ordinary case (not within a region), map the redo
2418 : ;; record to the following undos.
2419 : ;; I don't know how to do that in the undo-in-region case.
2420 0 : (let ((list buffer-undo-list))
2421 : ;; Strip any leading undo boundaries there might be, like we do
2422 : ;; above when checking.
2423 0 : (while (eq (car list) nil)
2424 0 : (setq list (cdr list)))
2425 0 : (puthash list
2426 : ;; Prevent identity mapping. This can happen if
2427 : ;; consecutive nils are erroneously in undo list.
2428 0 : (if (or undo-in-region (eq list pending-undo-list))
2429 : t
2430 0 : pending-undo-list)
2431 0 : undo-equiv-table))
2432 : ;; Don't specify a position in the undo record for the undo command.
2433 : ;; Instead, undoing this should move point to where the change is.
2434 0 : (let ((tail buffer-undo-list)
2435 : (prev nil))
2436 0 : (while (car tail)
2437 0 : (when (integerp (car tail))
2438 0 : (let ((pos (car tail)))
2439 0 : (if prev
2440 0 : (setcdr prev (cdr tail))
2441 0 : (setq buffer-undo-list (cdr tail)))
2442 0 : (setq tail (cdr tail))
2443 0 : (while (car tail)
2444 0 : (if (eq pos (car tail))
2445 0 : (if prev
2446 0 : (setcdr prev (cdr tail))
2447 0 : (setq buffer-undo-list (cdr tail)))
2448 0 : (setq prev tail))
2449 0 : (setq tail (cdr tail)))
2450 0 : (setq tail nil)))
2451 0 : (setq prev tail tail (cdr tail))))
2452 : ;; Record what the current undo list says,
2453 : ;; so the next command can tell if the buffer was modified in between.
2454 0 : (and modified (not (buffer-modified-p))
2455 0 : (with-current-buffer base-buffer
2456 0 : (delete-auto-save-file-if-necessary recent-save)))
2457 : ;; Display a message announcing success.
2458 0 : (if message
2459 0 : (message "%s" message))))
2460 :
2461 : (defun buffer-disable-undo (&optional buffer)
2462 : "Make BUFFER stop keeping undo information.
2463 : No argument or nil as argument means do this for the current buffer."
2464 : (interactive)
2465 0 : (with-current-buffer (if buffer (get-buffer buffer) (current-buffer))
2466 0 : (setq buffer-undo-list t)))
2467 :
2468 : (defun undo-only (&optional arg)
2469 : "Undo some previous changes.
2470 : Repeat this command to undo more changes.
2471 : A numeric ARG serves as a repeat count.
2472 : Contrary to `undo', this will not redo a previous undo."
2473 : (interactive "*p")
2474 0 : (let ((undo-no-redo t)) (undo arg)))
2475 :
2476 : (defvar undo-in-progress nil
2477 : "Non-nil while performing an undo.
2478 : Some change-hooks test this variable to do something different.")
2479 :
2480 : (defun undo-more (n)
2481 : "Undo back N undo-boundaries beyond what was already undone recently.
2482 : Call `undo-start' to get ready to undo recent changes,
2483 : then call `undo-more' one or more times to undo them."
2484 0 : (or (listp pending-undo-list)
2485 0 : (user-error (concat "No further undo information"
2486 0 : (and undo-in-region " for region"))))
2487 0 : (let ((undo-in-progress t))
2488 : ;; Note: The following, while pulling elements off
2489 : ;; `pending-undo-list' will call primitive change functions which
2490 : ;; will push more elements onto `buffer-undo-list'.
2491 0 : (setq pending-undo-list (primitive-undo n pending-undo-list))
2492 0 : (if (null pending-undo-list)
2493 0 : (setq pending-undo-list t))))
2494 :
2495 : (defun primitive-undo (n list)
2496 : "Undo N records from the front of the list LIST.
2497 : Return what remains of the list."
2498 :
2499 : ;; This is a good feature, but would make undo-start
2500 : ;; unable to do what is expected.
2501 : ;;(when (null (car (list)))
2502 : ;; ;; If the head of the list is a boundary, it is the boundary
2503 : ;; ;; preceding this command. Get rid of it and don't count it.
2504 : ;; (setq list (cdr list))))
2505 :
2506 0 : (let ((arg n)
2507 : ;; In a writable buffer, enable undoing read-only text that is
2508 : ;; so because of text properties.
2509 : (inhibit-read-only t)
2510 : ;; Don't let `intangible' properties interfere with undo.
2511 : (inhibit-point-motion-hooks t)
2512 : ;; We use oldlist only to check for EQ. ++kfs
2513 0 : (oldlist buffer-undo-list)
2514 : (did-apply nil)
2515 : (next nil))
2516 0 : (while (> arg 0)
2517 0 : (while (setq next (pop list)) ;Exit inner loop at undo boundary.
2518 : ;; Handle an integer by setting point to that value.
2519 0 : (pcase next
2520 0 : ((pred integerp) (goto-char next))
2521 : ;; Element (t . TIME) records previous modtime.
2522 : ;; Preserve any flag of NONEXISTENT_MODTIME_NSECS or
2523 : ;; UNKNOWN_MODTIME_NSECS.
2524 : (`(t . ,time)
2525 : ;; If this records an obsolete save
2526 : ;; (not matching the actual disk file)
2527 : ;; then don't mark unmodified.
2528 0 : (when (or (equal time (visited-file-modtime))
2529 0 : (and (consp time)
2530 0 : (equal (list (car time) (cdr time))
2531 0 : (visited-file-modtime))))
2532 0 : (when (fboundp 'unlock-buffer)
2533 0 : (unlock-buffer))
2534 0 : (set-buffer-modified-p nil)))
2535 : ;; Element (nil PROP VAL BEG . END) is property change.
2536 : (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare))
2537 0 : (when (or (> (point-min) beg) (< (point-max) end))
2538 0 : (error "Changes to be undone are outside visible portion of buffer"))
2539 0 : (put-text-property beg end prop val))
2540 : ;; Element (BEG . END) means range was inserted.
2541 : (`(,(and beg (pred integerp)) . ,(and end (pred integerp)))
2542 : ;; (and `(,beg . ,end) `(,(pred integerp) . ,(pred integerp)))
2543 : ;; Ideally: `(,(pred integerp beg) . ,(pred integerp end))
2544 0 : (when (or (> (point-min) beg) (< (point-max) end))
2545 0 : (error "Changes to be undone are outside visible portion of buffer"))
2546 : ;; Set point first thing, so that undoing this undo
2547 : ;; does not send point back to where it is now.
2548 0 : (goto-char beg)
2549 0 : (delete-region beg end))
2550 : ;; Element (apply FUN . ARGS) means call FUN to undo.
2551 : (`(apply . ,fun-args)
2552 0 : (let ((currbuff (current-buffer)))
2553 0 : (if (integerp (car fun-args))
2554 : ;; Long format: (apply DELTA START END FUN . ARGS).
2555 0 : (pcase-let* ((`(,delta ,start ,end ,fun . ,args) fun-args)
2556 0 : (start-mark (copy-marker start nil))
2557 0 : (end-mark (copy-marker end t)))
2558 0 : (when (or (> (point-min) start) (< (point-max) end))
2559 0 : (error "Changes to be undone are outside visible portion of buffer"))
2560 0 : (apply fun args) ;; Use `save-current-buffer'?
2561 : ;; Check that the function did what the entry
2562 : ;; said it would do.
2563 0 : (unless (and (= start start-mark)
2564 0 : (= (+ delta end) end-mark))
2565 0 : (error "Changes to be undone by function different than announced"))
2566 0 : (set-marker start-mark nil)
2567 0 : (set-marker end-mark nil))
2568 0 : (apply fun-args))
2569 0 : (unless (eq currbuff (current-buffer))
2570 0 : (error "Undo function switched buffer"))
2571 0 : (setq did-apply t)))
2572 : ;; Element (STRING . POS) means STRING was deleted.
2573 : (`(,(and string (pred stringp)) . ,(and pos (pred integerp)))
2574 0 : (when (let ((apos (abs pos)))
2575 0 : (or (< apos (point-min)) (> apos (point-max))))
2576 0 : (error "Changes to be undone are outside visible portion of buffer"))
2577 0 : (let (valid-marker-adjustments)
2578 : ;; Check that marker adjustments which were recorded
2579 : ;; with the (STRING . POS) record are still valid, ie
2580 : ;; the markers haven't moved. We check their validity
2581 : ;; before reinserting the string so as we don't need to
2582 : ;; mind marker insertion-type.
2583 0 : (while (and (markerp (car-safe (car list)))
2584 0 : (integerp (cdr-safe (car list))))
2585 0 : (let* ((marker-adj (pop list))
2586 0 : (m (car marker-adj)))
2587 0 : (and (eq (marker-buffer m) (current-buffer))
2588 0 : (= pos m)
2589 0 : (push marker-adj valid-marker-adjustments))))
2590 : ;; Insert string and adjust point
2591 0 : (if (< pos 0)
2592 0 : (progn
2593 0 : (goto-char (- pos))
2594 0 : (insert string))
2595 0 : (goto-char pos)
2596 0 : (insert string)
2597 0 : (goto-char pos))
2598 : ;; Adjust the valid marker adjustments
2599 0 : (dolist (adj valid-marker-adjustments)
2600 : ;; Insert might have invalidated some of the markers
2601 : ;; via modification hooks. Update only the currently
2602 : ;; valid ones (bug#25599).
2603 0 : (if (marker-buffer (car adj))
2604 0 : (set-marker (car adj)
2605 0 : (- (car adj) (cdr adj)))))))
2606 : ;; (MARKER . OFFSET) means a marker MARKER was adjusted by OFFSET.
2607 : (`(,(and marker (pred markerp)) . ,(and offset (pred integerp)))
2608 0 : (warn "Encountered %S entry in undo list with no matching (TEXT . POS) entry"
2609 0 : next)
2610 : ;; Even though these elements are not expected in the undo
2611 : ;; list, adjust them to be conservative for the 24.4
2612 : ;; release. (Bug#16818)
2613 0 : (when (marker-buffer marker)
2614 0 : (set-marker marker
2615 0 : (- marker offset)
2616 0 : (marker-buffer marker))))
2617 0 : (_ (error "Unrecognized entry in undo list %S" next))))
2618 0 : (setq arg (1- arg)))
2619 : ;; Make sure an apply entry produces at least one undo entry,
2620 : ;; so the test in `undo' for continuing an undo series
2621 : ;; will work right.
2622 0 : (if (and did-apply
2623 0 : (eq oldlist buffer-undo-list))
2624 0 : (setq buffer-undo-list
2625 0 : (cons (list 'apply 'cdr nil) buffer-undo-list))))
2626 0 : list)
2627 :
2628 : ;; Deep copy of a list
2629 : (defun undo-copy-list (list)
2630 : "Make a copy of undo list LIST."
2631 0 : (mapcar 'undo-copy-list-1 list))
2632 :
2633 : (defun undo-copy-list-1 (elt)
2634 0 : (if (consp elt)
2635 0 : (cons (car elt) (undo-copy-list-1 (cdr elt)))
2636 0 : elt))
2637 :
2638 : (defun undo-start (&optional beg end)
2639 : "Set `pending-undo-list' to the front of the undo list.
2640 : The next call to `undo-more' will undo the most recently made change.
2641 : If BEG and END are specified, then only undo elements
2642 : that apply to text between BEG and END are used; other undo elements
2643 : are ignored. If BEG and END are nil, all undo elements are used."
2644 0 : (if (eq buffer-undo-list t)
2645 0 : (user-error "No undo information in this buffer"))
2646 0 : (setq pending-undo-list
2647 0 : (if (and beg end (not (= beg end)))
2648 0 : (undo-make-selective-list (min beg end) (max beg end))
2649 0 : buffer-undo-list)))
2650 :
2651 : ;; The positions given in elements of the undo list are the positions
2652 : ;; as of the time that element was recorded to undo history. In
2653 : ;; general, subsequent buffer edits render those positions invalid in
2654 : ;; the current buffer, unless adjusted according to the intervening
2655 : ;; undo elements.
2656 : ;;
2657 : ;; Undo in region is a use case that requires adjustments to undo
2658 : ;; elements. It must adjust positions of elements in the region based
2659 : ;; on newer elements not in the region so as they may be correctly
2660 : ;; applied in the current buffer. undo-make-selective-list
2661 : ;; accomplishes this with its undo-deltas list of adjustments. An
2662 : ;; example undo history from oldest to newest:
2663 : ;;
2664 : ;; buf pos:
2665 : ;; 123456789 buffer-undo-list undo-deltas
2666 : ;; --------- ---------------- -----------
2667 : ;; aaa (1 . 4) (1 . -3)
2668 : ;; aaba (3 . 4) N/A (in region)
2669 : ;; ccaaba (1 . 3) (1 . -2)
2670 : ;; ccaabaddd (7 . 10) (7 . -3)
2671 : ;; ccaabdd ("ad" . 6) (6 . 2)
2672 : ;; ccaabaddd (6 . 8) (6 . -2)
2673 : ;; | |<-- region: "caab", from 2 to 6
2674 : ;;
2675 : ;; When the user starts a run of undos in region,
2676 : ;; undo-make-selective-list is called to create the full list of in
2677 : ;; region elements. Each element is adjusted forward chronologically
2678 : ;; through undo-deltas to determine if it is in the region.
2679 : ;;
2680 : ;; In the above example, the insertion of "b" is (3 . 4) in the
2681 : ;; buffer-undo-list. The undo-delta (1 . -2) causes (3 . 4) to become
2682 : ;; (5 . 6). The next three undo-deltas cause no adjustment, so (5
2683 : ;; . 6) is assessed as in the region and placed in the selective list.
2684 : ;; Notably, the end of region itself adjusts from "2 to 6" to "2 to 5"
2685 : ;; due to the selected element. The "b" insertion is the only element
2686 : ;; fully in the region, so in this example undo-make-selective-list
2687 : ;; returns (nil (5 . 6)).
2688 : ;;
2689 : ;; The adjustment of the (7 . 10) insertion of "ddd" shows an edge
2690 : ;; case. It is adjusted through the undo-deltas: ((6 . 2) (6 . -2)).
2691 : ;; Normally an undo-delta of (6 . 2) would cause positions after 6 to
2692 : ;; adjust by 2. However, they shouldn't adjust to less than 6, so (7
2693 : ;; . 10) adjusts to (6 . 8) due to the first undo delta.
2694 : ;;
2695 : ;; More interesting is how to adjust the "ddd" insertion due to the
2696 : ;; next undo-delta: (6 . -2), corresponding to reinsertion of "ad".
2697 : ;; If the reinsertion was a manual retyping of "ad", then the total
2698 : ;; adjustment should be (7 . 10) -> (6 . 8) -> (8 . 10). However, if
2699 : ;; the reinsertion was due to undo, one might expect the first "d"
2700 : ;; character would again be a part of the "ddd" text, meaning its
2701 : ;; total adjustment would be (7 . 10) -> (6 . 8) -> (7 . 10).
2702 : ;;
2703 : ;; undo-make-selective-list assumes in this situation that "ad" was a
2704 : ;; new edit, even if it was inserted because of an undo.
2705 : ;; Consequently, if the user undos in region "8 to 10" of the
2706 : ;; "ccaabaddd" buffer, they could be surprised that it becomes
2707 : ;; "ccaabad", as though the first "d" became detached from the
2708 : ;; original "ddd" insertion. This quirk is a FIXME.
2709 :
2710 : (defun undo-make-selective-list (start end)
2711 : "Return a list of undo elements for the region START to END.
2712 : The elements come from `buffer-undo-list', but we keep only the
2713 : elements inside this region, and discard those outside this
2714 : region. The elements' positions are adjusted so as the returned
2715 : list can be applied to the current buffer."
2716 0 : (let ((ulist buffer-undo-list)
2717 : ;; A list of position adjusted undo elements in the region.
2718 0 : (selective-list (list nil))
2719 : ;; A list of undo-deltas for out of region undo elements.
2720 : undo-deltas
2721 : undo-elt)
2722 0 : (while ulist
2723 0 : (when undo-no-redo
2724 0 : (while (gethash ulist undo-equiv-table)
2725 0 : (setq ulist (gethash ulist undo-equiv-table))))
2726 0 : (setq undo-elt (car ulist))
2727 0 : (cond
2728 0 : ((null undo-elt)
2729 : ;; Don't put two nils together in the list
2730 0 : (when (car selective-list)
2731 0 : (push nil selective-list)))
2732 0 : ((and (consp undo-elt) (eq (car undo-elt) t))
2733 : ;; This is a "was unmodified" element. Keep it
2734 : ;; if we have kept everything thus far.
2735 0 : (when (not undo-deltas)
2736 0 : (push undo-elt selective-list)))
2737 : ;; Skip over marker adjustments, instead relying
2738 : ;; on finding them after (TEXT . POS) elements
2739 0 : ((markerp (car-safe undo-elt))
2740 : nil)
2741 : (t
2742 0 : (let ((adjusted-undo-elt (undo-adjust-elt undo-elt
2743 0 : undo-deltas)))
2744 0 : (if (undo-elt-in-region adjusted-undo-elt start end)
2745 0 : (progn
2746 0 : (setq end (+ end (cdr (undo-delta adjusted-undo-elt))))
2747 0 : (push adjusted-undo-elt selective-list)
2748 : ;; Keep (MARKER . ADJUSTMENT) if their (TEXT . POS) was
2749 : ;; kept. primitive-undo may discard them later.
2750 0 : (when (and (stringp (car-safe adjusted-undo-elt))
2751 0 : (integerp (cdr-safe adjusted-undo-elt)))
2752 0 : (let ((list-i (cdr ulist)))
2753 0 : (while (markerp (car-safe (car list-i)))
2754 0 : (push (pop list-i) selective-list)))))
2755 0 : (let ((delta (undo-delta undo-elt)))
2756 0 : (when (/= 0 (cdr delta))
2757 0 : (push delta undo-deltas)))))))
2758 0 : (pop ulist))
2759 0 : (nreverse selective-list)))
2760 :
2761 : (defun undo-elt-in-region (undo-elt start end)
2762 : "Determine whether UNDO-ELT falls inside the region START ... END.
2763 : If it crosses the edge, we return nil.
2764 :
2765 : Generally this function is not useful for determining
2766 : whether (MARKER . ADJUSTMENT) undo elements are in the region,
2767 : because markers can be arbitrarily relocated. Instead, pass the
2768 : marker adjustment's corresponding (TEXT . POS) element."
2769 0 : (cond ((integerp undo-elt)
2770 0 : (and (>= undo-elt start)
2771 0 : (<= undo-elt end)))
2772 0 : ((eq undo-elt nil)
2773 : t)
2774 0 : ((atom undo-elt)
2775 : nil)
2776 0 : ((stringp (car undo-elt))
2777 : ;; (TEXT . POSITION)
2778 0 : (and (>= (abs (cdr undo-elt)) start)
2779 0 : (<= (abs (cdr undo-elt)) end)))
2780 0 : ((and (consp undo-elt) (markerp (car undo-elt)))
2781 : ;; (MARKER . ADJUSTMENT)
2782 0 : (<= start (car undo-elt) end))
2783 0 : ((null (car undo-elt))
2784 : ;; (nil PROPERTY VALUE BEG . END)
2785 0 : (let ((tail (nthcdr 3 undo-elt)))
2786 0 : (and (>= (car tail) start)
2787 0 : (<= (cdr tail) end))))
2788 0 : ((integerp (car undo-elt))
2789 : ;; (BEGIN . END)
2790 0 : (and (>= (car undo-elt) start)
2791 0 : (<= (cdr undo-elt) end)))))
2792 :
2793 : (defun undo-elt-crosses-region (undo-elt start end)
2794 : "Test whether UNDO-ELT crosses one edge of that region START ... END.
2795 : This assumes we have already decided that UNDO-ELT
2796 : is not *inside* the region START...END."
2797 : (declare (obsolete nil "25.1"))
2798 0 : (cond ((atom undo-elt) nil)
2799 0 : ((null (car undo-elt))
2800 : ;; (nil PROPERTY VALUE BEG . END)
2801 0 : (let ((tail (nthcdr 3 undo-elt)))
2802 0 : (and (< (car tail) end)
2803 0 : (> (cdr tail) start))))
2804 0 : ((integerp (car undo-elt))
2805 : ;; (BEGIN . END)
2806 0 : (and (< (car undo-elt) end)
2807 0 : (> (cdr undo-elt) start)))))
2808 :
2809 : (defun undo-adjust-elt (elt deltas)
2810 : "Return adjustment of undo element ELT by the undo DELTAS
2811 : list."
2812 0 : (pcase elt
2813 : ;; POSITION
2814 : ((pred integerp)
2815 0 : (undo-adjust-pos elt deltas))
2816 : ;; (BEG . END)
2817 : (`(,(and beg (pred integerp)) . ,(and end (pred integerp)))
2818 0 : (undo-adjust-beg-end beg end deltas))
2819 : ;; (TEXT . POSITION)
2820 : (`(,(and text (pred stringp)) . ,(and pos (pred integerp)))
2821 0 : (cons text (* (if (< pos 0) -1 1)
2822 0 : (undo-adjust-pos (abs pos) deltas))))
2823 : ;; (nil PROPERTY VALUE BEG . END)
2824 : (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare))
2825 0 : `(nil ,prop ,val . ,(undo-adjust-beg-end beg end deltas)))
2826 : ;; (apply DELTA START END FUN . ARGS)
2827 : ;; FIXME
2828 : ;; All others return same elt
2829 0 : (_ elt)))
2830 :
2831 : ;; (BEG . END) can adjust to the same positions, commonly when an
2832 : ;; insertion was undone and they are out of region, for example:
2833 : ;;
2834 : ;; buf pos:
2835 : ;; 123456789 buffer-undo-list undo-deltas
2836 : ;; --------- ---------------- -----------
2837 : ;; [...]
2838 : ;; abbaa (2 . 4) (2 . -2)
2839 : ;; aaa ("bb" . 2) (2 . 2)
2840 : ;; [...]
2841 : ;;
2842 : ;; "bb" insertion (2 . 4) adjusts to (2 . 2) because of the subsequent
2843 : ;; undo. Further adjustments to such an element should be the same as
2844 : ;; for (TEXT . POSITION) elements. The options are:
2845 : ;;
2846 : ;; 1: POSITION adjusts using <= (use-< nil), resulting in behavior
2847 : ;; analogous to marker insertion-type t.
2848 : ;;
2849 : ;; 2: POSITION adjusts using <, resulting in behavior analogous to
2850 : ;; marker insertion-type nil.
2851 : ;;
2852 : ;; There was no strong reason to prefer one or the other, except that
2853 : ;; the first is more consistent with prior undo in region behavior.
2854 : (defun undo-adjust-beg-end (beg end deltas)
2855 : "Return cons of adjustments to BEG and END by the undo DELTAS
2856 : list."
2857 0 : (let ((adj-beg (undo-adjust-pos beg deltas)))
2858 : ;; Note: option 2 above would be like (cons (min ...) adj-end)
2859 0 : (cons adj-beg
2860 0 : (max adj-beg (undo-adjust-pos end deltas t)))))
2861 :
2862 : (defun undo-adjust-pos (pos deltas &optional use-<)
2863 : "Return adjustment of POS by the undo DELTAS list, comparing
2864 : with < or <= based on USE-<."
2865 0 : (dolist (d deltas pos)
2866 0 : (when (if use-<
2867 0 : (< (car d) pos)
2868 0 : (<= (car d) pos))
2869 0 : (setq pos
2870 : ;; Don't allow pos to become less than the undo-delta
2871 : ;; position. This edge case is described in the overview
2872 : ;; comments.
2873 0 : (max (car d) (- pos (cdr d)))))))
2874 :
2875 : ;; Return the first affected buffer position and the delta for an undo element
2876 : ;; delta is defined as the change in subsequent buffer positions if we *did*
2877 : ;; the undo.
2878 : (defun undo-delta (undo-elt)
2879 0 : (if (consp undo-elt)
2880 0 : (cond ((stringp (car undo-elt))
2881 : ;; (TEXT . POSITION)
2882 0 : (cons (abs (cdr undo-elt)) (length (car undo-elt))))
2883 0 : ((integerp (car undo-elt))
2884 : ;; (BEGIN . END)
2885 0 : (cons (car undo-elt) (- (car undo-elt) (cdr undo-elt))))
2886 : (t
2887 0 : '(0 . 0)))
2888 0 : '(0 . 0)))
2889 :
2890 : ;;; Default undo-boundary addition
2891 : ;;
2892 : ;; This section adds a new undo-boundary at either after a command is
2893 : ;; called or in some cases on a timer called after a change is made in
2894 : ;; any buffer.
2895 : (defvar-local undo-auto--last-boundary-cause nil
2896 : "Describe the cause of the last undo-boundary.
2897 :
2898 : If `explicit', the last boundary was caused by an explicit call to
2899 : `undo-boundary', that is one not called by the code in this
2900 : section.
2901 :
2902 : If it is equal to `timer', then the last boundary was inserted
2903 : by `undo-auto--boundary-timer'.
2904 :
2905 : If it is equal to `command', then the last boundary was inserted
2906 : automatically after a command, that is by the code defined in
2907 : this section.
2908 :
2909 : If it is equal to a list, then the last boundary was inserted by
2910 : an amalgamating command. The car of the list is the number of
2911 : times an amalgamating command has been called, and the cdr are the
2912 : buffers that were changed during the last command.")
2913 :
2914 : (defvar undo-auto-current-boundary-timer nil
2915 : "Current timer which will run `undo-auto--boundary-timer' or nil.
2916 :
2917 : If set to non-nil, this will effectively disable the timer.")
2918 :
2919 : (defvar undo-auto--this-command-amalgamating nil
2920 : "Non-nil if `this-command' should be amalgamated.
2921 : This variable is set to nil by `undo-auto--boundaries' and is set
2922 : by `undo-auto-amalgamate'." )
2923 :
2924 : (defun undo-auto--needs-boundary-p ()
2925 : "Return non-nil if `buffer-undo-list' needs a boundary at the start."
2926 4 : (car-safe buffer-undo-list))
2927 :
2928 : (defun undo-auto--last-boundary-amalgamating-number ()
2929 : "Return the number of amalgamating last commands or nil.
2930 : Amalgamating commands are, by default, either
2931 : `self-insert-command' and `delete-char', but can be any command
2932 : that calls `undo-auto-amalgamate'."
2933 408 : (car-safe undo-auto--last-boundary-cause))
2934 :
2935 : (defun undo-auto--ensure-boundary (cause)
2936 : "Add an `undo-boundary' to the current buffer if needed.
2937 : REASON describes the reason that the boundary is being added; see
2938 : `undo-auto--last-boundary' for more information."
2939 4 : (when (and
2940 4 : (undo-auto--needs-boundary-p))
2941 4 : (let ((last-amalgamating
2942 4 : (undo-auto--last-boundary-amalgamating-number)))
2943 4 : (undo-boundary)
2944 4 : (setq undo-auto--last-boundary-cause
2945 4 : (if (eq 'amalgamate cause)
2946 0 : (cons
2947 0 : (if last-amalgamating (1+ last-amalgamating) 0)
2948 0 : undo-auto--undoably-changed-buffers)
2949 4 : cause)))))
2950 :
2951 : (defun undo-auto--boundaries (cause)
2952 : "Check recently changed buffers and add a boundary if necessary.
2953 : REASON describes the reason that the boundary is being added; see
2954 : `undo-last-boundary' for more information."
2955 : ;; (Bug #23785) All commands should ensure that there is an undo
2956 : ;; boundary whether they have changed the current buffer or not.
2957 1 : (when (eq cause 'command)
2958 1 : (add-to-list 'undo-auto--undoably-changed-buffers (current-buffer)))
2959 1 : (dolist (b undo-auto--undoably-changed-buffers)
2960 4 : (when (buffer-live-p b)
2961 4 : (with-current-buffer b
2962 4 : (undo-auto--ensure-boundary cause))))
2963 1 : (setq undo-auto--undoably-changed-buffers nil))
2964 :
2965 : (defun undo-auto--boundary-timer ()
2966 : "Timer which will run `undo--auto-boundary-timer'."
2967 1 : (setq undo-auto-current-boundary-timer nil)
2968 1 : (undo-auto--boundaries 'timer))
2969 :
2970 : (defun undo-auto--boundary-ensure-timer ()
2971 : "Ensure that the `undo-auto-boundary-timer' is set."
2972 10 : (unless undo-auto-current-boundary-timer
2973 2 : (setq undo-auto-current-boundary-timer
2974 10 : (run-at-time 10 nil #'undo-auto--boundary-timer))))
2975 :
2976 : (defvar undo-auto--undoably-changed-buffers nil
2977 : "List of buffers that have changed recently.
2978 :
2979 : This list is maintained by `undo-auto--undoable-change' and
2980 : `undo-auto--boundaries' and can be affected by changes to their
2981 : default values.")
2982 :
2983 : (defun undo-auto--add-boundary ()
2984 : "Add an `undo-boundary' in appropriate buffers."
2985 0 : (undo-auto--boundaries
2986 0 : (let ((amal undo-auto--this-command-amalgamating))
2987 0 : (setq undo-auto--this-command-amalgamating nil)
2988 0 : (if amal
2989 : 'amalgamate
2990 0 : 'command))))
2991 :
2992 : (defun undo-auto-amalgamate ()
2993 : "Amalgamate undo if necessary.
2994 : This function can be called before an amalgamating command. It
2995 : removes the previous `undo-boundary' if a series of such calls
2996 : have been made. By default `self-insert-command' and
2997 : `delete-char' are the only amalgamating commands, although this
2998 : function could be called by any command wishing to have this
2999 : behavior."
3000 404 : (let ((last-amalgamating-count
3001 404 : (undo-auto--last-boundary-amalgamating-number)))
3002 404 : (setq undo-auto--this-command-amalgamating t)
3003 404 : (when
3004 404 : last-amalgamating-count
3005 0 : (if
3006 0 : (and
3007 0 : (< last-amalgamating-count 20)
3008 0 : (eq this-command last-command))
3009 : ;; Amalgamate all buffers that have changed.
3010 0 : (dolist (b (cdr undo-auto--last-boundary-cause))
3011 0 : (when (buffer-live-p b)
3012 0 : (with-current-buffer
3013 0 : b
3014 0 : (when
3015 : ;; The head of `buffer-undo-list' is nil.
3016 : ;; `car-safe' doesn't work because
3017 : ;; `buffer-undo-list' need not be a list!
3018 0 : (and (listp buffer-undo-list)
3019 0 : (not (car buffer-undo-list)))
3020 0 : (setq buffer-undo-list
3021 0 : (cdr buffer-undo-list))))))
3022 404 : (setq undo-auto--last-boundary-cause 0)))))
3023 :
3024 : (defun undo-auto--undoable-change ()
3025 : "Called after every undoable buffer change."
3026 10 : (add-to-list 'undo-auto--undoably-changed-buffers (current-buffer))
3027 10 : (undo-auto--boundary-ensure-timer))
3028 : ;; End auto-boundary section
3029 :
3030 : (defun undo-amalgamate-change-group (handle)
3031 : "Amalgamate changes in change-group since HANDLE.
3032 : Remove all undo boundaries between the state of HANDLE and now.
3033 : HANDLE is as returned by `prepare-change-group'."
3034 0 : (dolist (elt handle)
3035 0 : (with-current-buffer (car elt)
3036 0 : (setq elt (cdr elt))
3037 0 : (when (consp buffer-undo-list)
3038 0 : (let ((old-car (car-safe elt))
3039 0 : (old-cdr (cdr-safe elt)))
3040 0 : (unwind-protect
3041 0 : (progn
3042 : ;; Temporarily truncate the undo log at ELT.
3043 0 : (when (consp elt)
3044 0 : (setcar elt t) (setcdr elt nil))
3045 0 : (when
3046 0 : (or (null elt) ;The undo-log was empty.
3047 : ;; `elt' is still in the log: normal case.
3048 0 : (eq elt (last buffer-undo-list))
3049 : ;; `elt' is not in the log any more, but that's because
3050 : ;; the log is "all new", so we should remove all
3051 : ;; boundaries from it.
3052 0 : (not (eq (last buffer-undo-list) (last old-cdr))))
3053 0 : (cl-callf (lambda (x) (delq nil x))
3054 0 : (if (car buffer-undo-list)
3055 0 : buffer-undo-list
3056 : ;; Preserve the undo-boundaries at either ends of the
3057 : ;; change-groups.
3058 0 : (cdr buffer-undo-list)))))
3059 : ;; Reset the modified cons cell ELT to its original content.
3060 0 : (when (consp elt)
3061 0 : (setcar elt old-car)
3062 0 : (setcdr elt old-cdr))))))))
3063 :
3064 :
3065 : (defcustom undo-ask-before-discard nil
3066 : "If non-nil ask about discarding undo info for the current command.
3067 : Normally, Emacs discards the undo info for the current command if
3068 : it exceeds `undo-outer-limit'. But if you set this option
3069 : non-nil, it asks in the echo area whether to discard the info.
3070 : If you answer no, there is a slight risk that Emacs might crash, so
3071 : only do it if you really want to undo the command.
3072 :
3073 : This option is mainly intended for debugging. You have to be
3074 : careful if you use it for other purposes. Garbage collection is
3075 : inhibited while the question is asked, meaning that Emacs might
3076 : leak memory. So you should make sure that you do not wait
3077 : excessively long before answering the question."
3078 : :type 'boolean
3079 : :group 'undo
3080 : :version "22.1")
3081 :
3082 : (defvar undo-extra-outer-limit nil
3083 : "If non-nil, an extra level of size that's ok in an undo item.
3084 : We don't ask the user about truncating the undo list until the
3085 : current item gets bigger than this amount.
3086 :
3087 : This variable only matters if `undo-ask-before-discard' is non-nil.")
3088 : (make-variable-buffer-local 'undo-extra-outer-limit)
3089 :
3090 : ;; When the first undo batch in an undo list is longer than
3091 : ;; undo-outer-limit, this function gets called to warn the user that
3092 : ;; the undo info for the current command was discarded. Garbage
3093 : ;; collection is inhibited around the call, so it had better not do a
3094 : ;; lot of consing.
3095 : (setq undo-outer-limit-function 'undo-outer-limit-truncate)
3096 : (defun undo-outer-limit-truncate (size)
3097 0 : (if undo-ask-before-discard
3098 0 : (when (or (null undo-extra-outer-limit)
3099 0 : (> size undo-extra-outer-limit))
3100 : ;; Don't ask the question again unless it gets even bigger.
3101 : ;; This applies, in particular, if the user quits from the question.
3102 : ;; Such a quit quits out of GC, but something else will call GC
3103 : ;; again momentarily. It will call this function again,
3104 : ;; but we don't want to ask the question again.
3105 0 : (setq undo-extra-outer-limit (+ size 50000))
3106 0 : (if (let (use-dialog-box track-mouse executing-kbd-macro )
3107 0 : (yes-or-no-p (format-message
3108 : "Buffer `%s' undo info is %d bytes long; discard it? "
3109 0 : (buffer-name) size)))
3110 0 : (progn (setq buffer-undo-list nil)
3111 0 : (setq undo-extra-outer-limit nil)
3112 0 : t)
3113 0 : nil))
3114 0 : (display-warning '(undo discard-info)
3115 0 : (concat
3116 0 : (format-message
3117 : "Buffer `%s' undo info was %d bytes long.\n"
3118 0 : (buffer-name) size)
3119 : "The undo info was discarded because it exceeded \
3120 : `undo-outer-limit'.
3121 :
3122 : This is normal if you executed a command that made a huge change
3123 : to the buffer. In that case, to prevent similar problems in the
3124 : future, set `undo-outer-limit' to a value that is large enough to
3125 : cover the maximum size of normal changes you expect a single
3126 : command to make, but not so large that it might exceed the
3127 : maximum memory allotted to Emacs.
3128 :
3129 : If you did not execute any such command, the situation is
3130 : probably due to a bug and you should report it.
3131 :
3132 : You can disable the popping up of this buffer by adding the entry
3133 : \(undo discard-info) to the user option `warning-suppress-types',
3134 0 : which is defined in the `warnings' library.\n")
3135 0 : :warning)
3136 0 : (setq buffer-undo-list nil)
3137 0 : t))
3138 :
3139 : (defcustom password-word-equivalents
3140 : '("password" "passcode" "passphrase" "pass phrase"
3141 : ; These are sorted according to the GNU en_US locale.
3142 : "암호" ; ko
3143 : "パスワード" ; ja
3144 : "ପ୍ରବେଶ ସଙ୍କେତ" ; or
3145 : "ពាក្យសម្ងាត់" ; km
3146 : "adgangskode" ; da
3147 : "contraseña" ; es
3148 : "contrasenya" ; ca
3149 : "geslo" ; sl
3150 : "hasło" ; pl
3151 : "heslo" ; cs, sk
3152 : "iphasiwedi" ; zu
3153 : "jelszó" ; hu
3154 : "lösenord" ; sv
3155 : "lozinka" ; hr, sr
3156 : "mật khẩu" ; vi
3157 : "mot de passe" ; fr
3158 : "parola" ; tr
3159 : "pasahitza" ; eu
3160 : "passord" ; nb
3161 : "passwort" ; de
3162 : "pasvorto" ; eo
3163 : "salasana" ; fi
3164 : "senha" ; pt
3165 : "slaptažodis" ; lt
3166 : "wachtwoord" ; nl
3167 : "كلمة السر" ; ar
3168 : "ססמה" ; he
3169 : "лозинка" ; sr
3170 : "пароль" ; kk, ru, uk
3171 : "गुप्तशब्द" ; mr
3172 : "शब्दकूट" ; hi
3173 : "પાસવર્ડ" ; gu
3174 : "సంకేతపదము" ; te
3175 : "ਪਾਸਵਰਡ" ; pa
3176 : "ಗುಪ್ತಪದ" ; kn
3177 : "கடவுச்சொல்" ; ta
3178 : "അടയാളവാക്ക്" ; ml
3179 : "গুপ্তশব্দ" ; as
3180 : "পাসওয়ার্ড" ; bn_IN
3181 : "රහස්පදය" ; si
3182 : "密码" ; zh_CN
3183 : "密碼" ; zh_TW
3184 : )
3185 : "List of words equivalent to \"password\".
3186 : This is used by Shell mode and other parts of Emacs to recognize
3187 : password prompts, including prompts in languages other than
3188 : English. Different case choices should not be assumed to be
3189 : included; callers should bind `case-fold-search' to t."
3190 : :type '(repeat string)
3191 : :version "24.4"
3192 : :group 'processes)
3193 :
3194 : (defvar shell-command-history nil
3195 : "History list for some commands that read shell commands.
3196 :
3197 : Maximum length of the history list is determined by the value
3198 : of `history-length', which see.")
3199 :
3200 : (defvar shell-command-switch (purecopy "-c")
3201 : "Switch used to have the shell execute its command line argument.")
3202 :
3203 : (defvar shell-command-default-error-buffer nil
3204 : "Buffer name for `shell-command' and `shell-command-on-region' error output.
3205 : This buffer is used when `shell-command' or `shell-command-on-region'
3206 : is run interactively. A value of nil means that output to stderr and
3207 : stdout will be intermixed in the output stream.")
3208 :
3209 : (declare-function mailcap-file-default-commands "mailcap" (files))
3210 : (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep))
3211 :
3212 : (defun minibuffer-default-add-shell-commands ()
3213 : "Return a list of all commands associated with the current file.
3214 : This function is used to add all related commands retrieved by `mailcap'
3215 : to the end of the list of defaults just after the default value."
3216 : (interactive)
3217 0 : (let* ((filename (if (listp minibuffer-default)
3218 0 : (car minibuffer-default)
3219 0 : minibuffer-default))
3220 0 : (commands (and filename (require 'mailcap nil t)
3221 0 : (mailcap-file-default-commands (list filename)))))
3222 0 : (setq commands (mapcar (lambda (command)
3223 0 : (concat command " " filename))
3224 0 : commands))
3225 0 : (if (listp minibuffer-default)
3226 0 : (append minibuffer-default commands)
3227 0 : (cons minibuffer-default commands))))
3228 :
3229 : (declare-function shell-completion-vars "shell" ())
3230 :
3231 : (defvar minibuffer-local-shell-command-map
3232 : (let ((map (make-sparse-keymap)))
3233 : (set-keymap-parent map minibuffer-local-map)
3234 : (define-key map "\t" 'completion-at-point)
3235 : map)
3236 : "Keymap used for completing shell commands in minibuffer.")
3237 :
3238 : (defun read-shell-command (prompt &optional initial-contents hist &rest args)
3239 : "Read a shell command from the minibuffer.
3240 : The arguments are the same as the ones of `read-from-minibuffer',
3241 : except READ and KEYMAP are missing and HIST defaults
3242 : to `shell-command-history'."
3243 0 : (require 'shell)
3244 0 : (minibuffer-with-setup-hook
3245 : (lambda ()
3246 0 : (shell-completion-vars)
3247 0 : (set (make-local-variable 'minibuffer-default-add-function)
3248 0 : 'minibuffer-default-add-shell-commands))
3249 0 : (apply 'read-from-minibuffer prompt initial-contents
3250 0 : minibuffer-local-shell-command-map
3251 : nil
3252 0 : (or hist 'shell-command-history)
3253 0 : args)))
3254 :
3255 : (defcustom async-shell-command-buffer 'confirm-new-buffer
3256 : "What to do when the output buffer is used by another shell command.
3257 : This option specifies how to resolve the conflict where a new command
3258 : wants to direct its output to the buffer `*Async Shell Command*',
3259 : but this buffer is already taken by another running shell command.
3260 :
3261 : The value `confirm-kill-process' is used to ask for confirmation before
3262 : killing the already running process and running a new process
3263 : in the same buffer, `confirm-new-buffer' for confirmation before running
3264 : the command in a new buffer with a name other than the default buffer name,
3265 : `new-buffer' for doing the same without confirmation,
3266 : `confirm-rename-buffer' for confirmation before renaming the existing
3267 : output buffer and running a new command in the default buffer,
3268 : `rename-buffer' for doing the same without confirmation."
3269 : :type '(choice (const :tag "Confirm killing of running command"
3270 : confirm-kill-process)
3271 : (const :tag "Confirm creation of a new buffer"
3272 : confirm-new-buffer)
3273 : (const :tag "Create a new buffer"
3274 : new-buffer)
3275 : (const :tag "Confirm renaming of existing buffer"
3276 : confirm-rename-buffer)
3277 : (const :tag "Rename the existing buffer"
3278 : rename-buffer))
3279 : :group 'shell
3280 : :version "24.3")
3281 :
3282 : (defcustom async-shell-command-display-buffer t
3283 : "Whether to display the command buffer immediately.
3284 : If t, display the buffer immediately; if nil, wait until there
3285 : is output."
3286 : :type '(choice (const :tag "Display buffer immediately"
3287 : t)
3288 : (const :tag "Display buffer on output"
3289 : nil))
3290 : :group 'shell
3291 : :version "26.1")
3292 :
3293 : (defun shell-command--save-pos-or-erase ()
3294 : "Store a buffer position or erase the buffer.
3295 : See `shell-command-dont-erase-buffer'."
3296 0 : (let ((sym shell-command-dont-erase-buffer)
3297 : pos)
3298 0 : (setq buffer-read-only nil)
3299 : ;; Setting buffer-read-only to nil doesn't suffice
3300 : ;; if some text has a non-nil read-only property,
3301 : ;; which comint sometimes adds for prompts.
3302 0 : (setq pos
3303 0 : (cond ((eq sym 'save-point) (point))
3304 0 : ((eq sym 'beg-last-out) (point-max))
3305 0 : ((not sym)
3306 0 : (let ((inhibit-read-only t))
3307 0 : (erase-buffer) nil))))
3308 0 : (when pos
3309 0 : (goto-char (point-max))
3310 0 : (push (cons (current-buffer) pos)
3311 0 : shell-command-saved-pos))))
3312 :
3313 : (defun shell-command--set-point-after-cmd (&optional buffer)
3314 : "Set point in BUFFER after command complete.
3315 : BUFFER is the output buffer of the command; if nil, then defaults
3316 : to the current BUFFER.
3317 : Set point to the `cdr' of the element in `shell-command-saved-pos'
3318 : whose `car' is BUFFER."
3319 0 : (when shell-command-dont-erase-buffer
3320 0 : (let* ((sym shell-command-dont-erase-buffer)
3321 0 : (buf (or buffer (current-buffer)))
3322 0 : (pos (alist-get buf shell-command-saved-pos)))
3323 0 : (setq shell-command-saved-pos
3324 0 : (assq-delete-all buf shell-command-saved-pos))
3325 0 : (when (buffer-live-p buf)
3326 0 : (let ((win (car (get-buffer-window-list buf)))
3327 0 : (pmax (with-current-buffer buf (point-max))))
3328 0 : (unless (and pos (memq sym '(save-point beg-last-out)))
3329 0 : (setq pos pmax))
3330 : ;; Set point in the window displaying buf, if any; otherwise
3331 : ;; display buf temporary in selected frame and set the point.
3332 0 : (if win
3333 0 : (set-window-point win pos)
3334 0 : (save-window-excursion
3335 0 : (let ((win (display-buffer
3336 0 : buf
3337 0 : '(nil (inhibit-switch-frame . t)))))
3338 0 : (set-window-point win pos)))))))))
3339 :
3340 : (defun async-shell-command (command &optional output-buffer error-buffer)
3341 : "Execute string COMMAND asynchronously in background.
3342 :
3343 : Like `shell-command', but adds `&' at the end of COMMAND
3344 : to execute it asynchronously.
3345 :
3346 : The output appears in the buffer `*Async Shell Command*'.
3347 : That buffer is in shell mode.
3348 :
3349 : You can configure `async-shell-command-buffer' to specify what to do in
3350 : case when `*Async Shell Command*' buffer is already taken by another
3351 : running shell command. To run COMMAND without displaying the output
3352 : in a window you can configure `display-buffer-alist' to use the action
3353 : `display-buffer-no-window' for the buffer `*Async Shell Command*'.
3354 :
3355 : In Elisp, you will often be better served by calling `start-process'
3356 : directly, since it offers more control and does not impose the use of a
3357 : shell (with its need to quote arguments)."
3358 : (interactive
3359 0 : (list
3360 0 : (read-shell-command "Async shell command: " nil nil
3361 0 : (let ((filename
3362 0 : (cond
3363 0 : (buffer-file-name)
3364 0 : ((eq major-mode 'dired-mode)
3365 0 : (dired-get-filename nil t)))))
3366 0 : (and filename (file-relative-name filename))))
3367 0 : current-prefix-arg
3368 0 : shell-command-default-error-buffer))
3369 10 : (unless (string-match "&[ \t]*\\'" command)
3370 10 : (setq command (concat command " &")))
3371 10 : (shell-command command output-buffer error-buffer))
3372 :
3373 : (defun shell-command (command &optional output-buffer error-buffer)
3374 : "Execute string COMMAND in inferior shell; display output, if any.
3375 : With prefix argument, insert the COMMAND's output at point.
3376 :
3377 : Interactively, prompt for COMMAND in the minibuffer.
3378 :
3379 : If COMMAND ends in `&', execute it asynchronously.
3380 : The output appears in the buffer `*Async Shell Command*'.
3381 : That buffer is in shell mode. You can also use
3382 : `async-shell-command' that automatically adds `&'.
3383 :
3384 : Otherwise, COMMAND is executed synchronously. The output appears in
3385 : the buffer `*Shell Command Output*'. If the output is short enough to
3386 : display in the echo area (which is determined by the variables
3387 : `resize-mini-windows' and `max-mini-window-height'), it is shown
3388 : there, but it is nonetheless available in buffer `*Shell Command
3389 : Output*' even though that buffer is not automatically displayed.
3390 :
3391 : To specify a coding system for converting non-ASCII characters
3392 : in the shell command output, use \\[universal-coding-system-argument] \
3393 : before this command.
3394 :
3395 : Noninteractive callers can specify coding systems by binding
3396 : `coding-system-for-read' and `coding-system-for-write'.
3397 :
3398 : The optional second argument OUTPUT-BUFFER, if non-nil,
3399 : says to put the output in some other buffer.
3400 : If OUTPUT-BUFFER is a buffer or buffer name, erase that buffer
3401 : and insert the output there; a non-nil value of
3402 : `shell-command-dont-erase-buffer' prevent to erase the buffer.
3403 : If OUTPUT-BUFFER is not a buffer and not nil, insert the output
3404 : in current buffer after point leaving mark after it.
3405 : This cannot be done asynchronously.
3406 :
3407 : If the command terminates without error, but generates output,
3408 : and you did not specify \"insert it in the current buffer\",
3409 : the output can be displayed in the echo area or in its buffer.
3410 : If the output is short enough to display in the echo area
3411 : \(determined by the variable `max-mini-window-height' if
3412 : `resize-mini-windows' is non-nil), it is shown there.
3413 : Otherwise,the buffer containing the output is displayed.
3414 :
3415 : If there is output and an error, and you did not specify \"insert it
3416 : in the current buffer\", a message about the error goes at the end
3417 : of the output.
3418 :
3419 : If the optional third argument ERROR-BUFFER is non-nil, it is a buffer
3420 : or buffer name to which to direct the command's standard error output.
3421 : If it is nil, error output is mingled with regular output.
3422 : In an interactive call, the variable `shell-command-default-error-buffer'
3423 : specifies the value of ERROR-BUFFER.
3424 :
3425 : In Elisp, you will often be better served by calling `call-process' or
3426 : `start-process' directly, since it offers more control and does not impose
3427 : the use of a shell (with its need to quote arguments)."
3428 :
3429 : (interactive
3430 0 : (list
3431 0 : (read-shell-command "Shell command: " nil nil
3432 0 : (let ((filename
3433 0 : (cond
3434 0 : (buffer-file-name)
3435 0 : ((eq major-mode 'dired-mode)
3436 0 : (dired-get-filename nil t)))))
3437 0 : (and filename (file-relative-name filename))))
3438 0 : current-prefix-arg
3439 0 : shell-command-default-error-buffer))
3440 : ;; Look for a handler in case default-directory is a remote file name.
3441 14 : (let ((handler
3442 14 : (find-file-name-handler (directory-file-name default-directory)
3443 14 : 'shell-command)))
3444 14 : (if handler
3445 14 : (funcall handler 'shell-command command output-buffer error-buffer)
3446 0 : (if (and output-buffer
3447 0 : (not (or (bufferp output-buffer) (stringp output-buffer))))
3448 : ;; Output goes in current buffer.
3449 0 : (let ((error-file
3450 0 : (if error-buffer
3451 0 : (make-temp-file
3452 0 : (expand-file-name "scor"
3453 0 : (or small-temporary-file-directory
3454 0 : temporary-file-directory)))
3455 0 : nil)))
3456 0 : (barf-if-buffer-read-only)
3457 0 : (push-mark nil t)
3458 : ;; We do not use -f for csh; we will not support broken use of
3459 : ;; .cshrcs. Even the BSD csh manual says to use
3460 : ;; "if ($?prompt) exit" before things which are not useful
3461 : ;; non-interactively. Besides, if someone wants their other
3462 : ;; aliases for shell commands then they can still have them.
3463 0 : (call-process shell-file-name nil
3464 0 : (if error-file
3465 0 : (list t error-file)
3466 0 : t)
3467 0 : nil shell-command-switch command)
3468 0 : (when (and error-file (file-exists-p error-file))
3469 0 : (if (< 0 (nth 7 (file-attributes error-file)))
3470 0 : (with-current-buffer (get-buffer-create error-buffer)
3471 0 : (let ((pos-from-end (- (point-max) (point))))
3472 0 : (or (bobp)
3473 0 : (insert "\f\n"))
3474 : ;; Do no formatting while reading error file,
3475 : ;; because that can run a shell command, and we
3476 : ;; don't want that to cause an infinite recursion.
3477 0 : (format-insert-file error-file nil)
3478 : ;; Put point after the inserted errors.
3479 0 : (goto-char (- (point-max) pos-from-end)))
3480 0 : (display-buffer (current-buffer))))
3481 0 : (delete-file error-file))
3482 : ;; This is like exchange-point-and-mark, but doesn't
3483 : ;; activate the mark. It is cleaner to avoid activation,
3484 : ;; even though the command loop would deactivate the mark
3485 : ;; because we inserted text.
3486 0 : (goto-char (prog1 (mark t)
3487 0 : (set-marker (mark-marker) (point)
3488 0 : (current-buffer)))))
3489 : ;; Output goes in a separate buffer.
3490 : ;; Preserve the match data in case called from a program.
3491 : ;; FIXME: It'd be ridiculous for an Elisp function to call
3492 : ;; shell-command and assume that it won't mess the match-data!
3493 0 : (save-match-data
3494 0 : (if (string-match "[ \t]*&[ \t]*\\'" command)
3495 : ;; Command ending with ampersand means asynchronous.
3496 0 : (let ((buffer (get-buffer-create
3497 0 : (or output-buffer "*Async Shell Command*")))
3498 0 : (directory default-directory)
3499 : proc)
3500 : ;; Remove the ampersand.
3501 0 : (setq command (substring command 0 (match-beginning 0)))
3502 : ;; Ask the user what to do with already running process.
3503 0 : (setq proc (get-buffer-process buffer))
3504 0 : (when proc
3505 0 : (cond
3506 0 : ((eq async-shell-command-buffer 'confirm-kill-process)
3507 : ;; If will kill a process, query first.
3508 0 : (if (yes-or-no-p "A command is running in the default buffer. Kill it? ")
3509 0 : (kill-process proc)
3510 0 : (error "Shell command in progress")))
3511 0 : ((eq async-shell-command-buffer 'confirm-new-buffer)
3512 : ;; If will create a new buffer, query first.
3513 0 : (if (yes-or-no-p "A command is running in the default buffer. Use a new buffer? ")
3514 0 : (setq buffer (generate-new-buffer
3515 0 : (or (and (bufferp output-buffer) (buffer-name output-buffer))
3516 0 : output-buffer "*Async Shell Command*")))
3517 0 : (error "Shell command in progress")))
3518 0 : ((eq async-shell-command-buffer 'new-buffer)
3519 : ;; It will create a new buffer.
3520 0 : (setq buffer (generate-new-buffer
3521 0 : (or (and (bufferp output-buffer) (buffer-name output-buffer))
3522 0 : output-buffer "*Async Shell Command*"))))
3523 0 : ((eq async-shell-command-buffer 'confirm-rename-buffer)
3524 : ;; If will rename the buffer, query first.
3525 0 : (if (yes-or-no-p "A command is running in the default buffer. Rename it? ")
3526 0 : (progn
3527 0 : (with-current-buffer buffer
3528 0 : (rename-uniquely))
3529 0 : (setq buffer (get-buffer-create
3530 0 : (or output-buffer "*Async Shell Command*"))))
3531 0 : (error "Shell command in progress")))
3532 0 : ((eq async-shell-command-buffer 'rename-buffer)
3533 : ;; It will rename the buffer.
3534 0 : (with-current-buffer buffer
3535 0 : (rename-uniquely))
3536 0 : (setq buffer (get-buffer-create
3537 0 : (or output-buffer "*Async Shell Command*"))))))
3538 0 : (with-current-buffer buffer
3539 0 : (shell-command--save-pos-or-erase)
3540 0 : (setq default-directory directory)
3541 0 : (setq proc (start-process "Shell" buffer shell-file-name
3542 0 : shell-command-switch command))
3543 0 : (setq mode-line-process '(":%s"))
3544 0 : (require 'shell) (shell-mode)
3545 0 : (set-process-sentinel proc 'shell-command-sentinel)
3546 : ;; Use the comint filter for proper handling of carriage motion
3547 : ;; (see `comint-inhibit-carriage-motion'),.
3548 0 : (set-process-filter proc 'comint-output-filter)
3549 0 : (if async-shell-command-display-buffer
3550 0 : (display-buffer buffer '(nil (allow-no-window . t)))
3551 0 : (add-function :before (process-filter proc)
3552 0 : `(lambda (process string)
3553 : (when (and (= 0 (buffer-size (process-buffer process)))
3554 : (string= (buffer-name (process-buffer process))
3555 0 : ,(or output-buffer "*Async Shell Command*")))
3556 0 : (display-buffer (process-buffer process))))
3557 0 : ))
3558 0 : ))
3559 : ;; Otherwise, command is executed synchronously.
3560 0 : (shell-command-on-region (point) (point) command
3561 14 : output-buffer nil error-buffer)))))))
3562 :
3563 : (defun display-message-or-buffer (message &optional buffer-name action frame)
3564 : "Display MESSAGE in the echo area if possible, otherwise in a pop-up buffer.
3565 : MESSAGE may be either a string or a buffer.
3566 :
3567 : A pop-up buffer is displayed using `display-buffer' if MESSAGE is too long
3568 : for maximum height of the echo area, as defined by `max-mini-window-height'
3569 : if `resize-mini-windows' is non-nil.
3570 :
3571 : Returns either the string shown in the echo area, or when a pop-up
3572 : buffer is used, the window used to display it.
3573 :
3574 : If MESSAGE is a string, then the optional argument BUFFER-NAME is the
3575 : name of the buffer used to display it in the case where a pop-up buffer
3576 : is used, defaulting to `*Message*'. In the case where MESSAGE is a
3577 : string and it is displayed in the echo area, it is not specified whether
3578 : the contents are inserted into the buffer anyway.
3579 :
3580 : Optional arguments ACTION and FRAME are as for `display-buffer',
3581 : and are only used if a pop-up buffer is displayed."
3582 2 : (cond ((and (stringp message) (not (string-match "\n" message)))
3583 : ;; Trivial case where we can use the echo area
3584 0 : (message "%s" message))
3585 2 : ((and (stringp message)
3586 2 : (= (string-match "\n" message) (1- (length message))))
3587 : ;; Trivial case where we can just remove single trailing newline
3588 0 : (message "%s" (substring message 0 (1- (length message)))))
3589 : (t
3590 : ;; General case
3591 2 : (with-current-buffer
3592 2 : (if (bufferp message)
3593 2 : message
3594 2 : (get-buffer-create (or buffer-name "*Message*")))
3595 :
3596 2 : (unless (bufferp message)
3597 0 : (erase-buffer)
3598 2 : (insert message))
3599 :
3600 2 : (let ((lines
3601 2 : (if (= (buffer-size) 0)
3602 : 0
3603 2 : (count-screen-lines nil nil nil (minibuffer-window)))))
3604 2 : (cond ((= lines 0))
3605 2 : ((and (or (<= lines 1)
3606 2 : (<= lines
3607 2 : (if resize-mini-windows
3608 2 : (cond ((floatp max-mini-window-height)
3609 2 : (* (frame-height)
3610 2 : max-mini-window-height))
3611 0 : ((integerp max-mini-window-height)
3612 0 : max-mini-window-height)
3613 : (t
3614 2 : 1))
3615 2 : 1)))
3616 : ;; Don't use the echo area if the output buffer is
3617 : ;; already displayed in the selected frame.
3618 2 : (not (get-buffer-window (current-buffer))))
3619 : ;; Echo area
3620 2 : (goto-char (point-max))
3621 2 : (when (bolp)
3622 2 : (backward-char 1))
3623 2 : (message "%s" (buffer-substring (point-min) (point))))
3624 : (t
3625 : ;; Buffer
3626 0 : (goto-char (point-min))
3627 2 : (display-buffer (current-buffer) action frame))))))))
3628 :
3629 :
3630 : ;; We have a sentinel to prevent insertion of a termination message
3631 : ;; in the buffer itself, and to set the point in the buffer when
3632 : ;; `shell-command-dont-erase-buffer' is non-nil.
3633 : (defun shell-command-sentinel (process signal)
3634 0 : (when (memq (process-status process) '(exit signal))
3635 0 : (shell-command--set-point-after-cmd (process-buffer process))
3636 0 : (message "%s: %s."
3637 0 : (car (cdr (cdr (process-command process))))
3638 0 : (substring signal 0 -1))))
3639 :
3640 : (defun shell-command-on-region (start end command
3641 : &optional output-buffer replace
3642 : error-buffer display-error-buffer
3643 : region-noncontiguous-p)
3644 : "Execute string COMMAND in inferior shell with region as input.
3645 : Normally display output (if any) in temp buffer `*Shell Command Output*';
3646 : Prefix arg means replace the region with it. Return the exit code of
3647 : COMMAND.
3648 :
3649 : To specify a coding system for converting non-ASCII characters
3650 : in the input and output to the shell command, use \\[universal-coding-system-argument]
3651 : before this command. By default, the input (from the current buffer)
3652 : is encoded using coding-system specified by `process-coding-system-alist',
3653 : falling back to `default-process-coding-system' if no match for COMMAND
3654 : is found in `process-coding-system-alist'.
3655 :
3656 : Noninteractive callers can specify coding systems by binding
3657 : `coding-system-for-read' and `coding-system-for-write'.
3658 :
3659 : If the command generates output, the output may be displayed
3660 : in the echo area or in a buffer.
3661 : If the output is short enough to display in the echo area
3662 : \(determined by the variable `max-mini-window-height' if
3663 : `resize-mini-windows' is non-nil), it is shown there.
3664 : Otherwise it is displayed in the buffer `*Shell Command Output*'.
3665 : The output is available in that buffer in both cases.
3666 :
3667 : If there is output and an error, a message about the error
3668 : appears at the end of the output.
3669 :
3670 : Optional fourth arg OUTPUT-BUFFER specifies where to put the
3671 : command's output. If the value is a buffer or buffer name,
3672 : erase that buffer and insert the output there; a non-nil value of
3673 : `shell-command-dont-erase-buffer' prevent to erase the buffer.
3674 : If the value is nil, use the buffer `*Shell Command Output*'.
3675 : Any other non-nil value means to insert the output in the
3676 : current buffer after START.
3677 :
3678 : Optional fifth arg REPLACE, if non-nil, means to insert the
3679 : output in place of text from START to END, putting point and mark
3680 : around it.
3681 :
3682 : Optional sixth arg ERROR-BUFFER, if non-nil, specifies a buffer
3683 : or buffer name to which to direct the command's standard error
3684 : output. If nil, error output is mingled with regular output.
3685 : When called interactively, `shell-command-default-error-buffer'
3686 : is used for ERROR-BUFFER.
3687 :
3688 : Optional seventh arg DISPLAY-ERROR-BUFFER, if non-nil, means to
3689 : display the error buffer if there were any errors. When called
3690 : interactively, this is t."
3691 0 : (interactive (let (string)
3692 0 : (unless (mark)
3693 0 : (user-error "The mark is not set now, so there is no region"))
3694 : ;; Do this before calling region-beginning
3695 : ;; and region-end, in case subprocess output
3696 : ;; relocates them while we are in the minibuffer.
3697 0 : (setq string (read-shell-command "Shell command on region: "))
3698 : ;; call-interactively recognizes region-beginning and
3699 : ;; region-end specially, leaving them in the history.
3700 0 : (list (region-beginning) (region-end)
3701 0 : string
3702 0 : current-prefix-arg
3703 0 : current-prefix-arg
3704 0 : shell-command-default-error-buffer
3705 : t
3706 0 : (region-noncontiguous-p))))
3707 0 : (let ((error-file
3708 0 : (if error-buffer
3709 0 : (make-temp-file
3710 0 : (expand-file-name "scor"
3711 0 : (or small-temporary-file-directory
3712 0 : temporary-file-directory)))
3713 0 : nil))
3714 : exit-status)
3715 : ;; Unless a single contiguous chunk is selected, operate on multiple chunks.
3716 0 : (if region-noncontiguous-p
3717 0 : (let ((input (concat (funcall region-extract-function 'delete) "\n"))
3718 : output)
3719 0 : (with-temp-buffer
3720 0 : (insert input)
3721 0 : (call-process-region (point-min) (point-max)
3722 0 : shell-file-name t t
3723 0 : nil shell-command-switch
3724 0 : command)
3725 0 : (setq output (split-string (buffer-string) "\n")))
3726 0 : (goto-char start)
3727 0 : (funcall region-insert-function output))
3728 0 : (if (or replace
3729 0 : (and output-buffer
3730 0 : (not (or (bufferp output-buffer) (stringp output-buffer)))))
3731 : ;; Replace specified region with output from command.
3732 0 : (let ((swap (and replace (< start end))))
3733 : ;; Don't muck with mark unless REPLACE says we should.
3734 0 : (goto-char start)
3735 0 : (and replace (push-mark (point) 'nomsg))
3736 0 : (setq exit-status
3737 0 : (call-shell-region start end command replace
3738 0 : (if error-file
3739 0 : (list t error-file)
3740 0 : t)))
3741 : ;; It is rude to delete a buffer which the command is not using.
3742 : ;; (let ((shell-buffer (get-buffer "*Shell Command Output*")))
3743 : ;; (and shell-buffer (not (eq shell-buffer (current-buffer)))
3744 : ;; (kill-buffer shell-buffer)))
3745 : ;; Don't muck with mark unless REPLACE says we should.
3746 0 : (and replace swap (exchange-point-and-mark)))
3747 : ;; No prefix argument: put the output in a temp buffer,
3748 : ;; replacing its entire contents.
3749 0 : (let ((buffer (get-buffer-create
3750 0 : (or output-buffer "*Shell Command Output*"))))
3751 0 : (unwind-protect
3752 0 : (if (and (eq buffer (current-buffer))
3753 0 : (or (not shell-command-dont-erase-buffer)
3754 0 : (and (not (eq buffer (get-buffer "*Shell Command Output*")))
3755 0 : (not (region-active-p)))))
3756 : ;; If the input is the same buffer as the output,
3757 : ;; delete everything but the specified region,
3758 : ;; then replace that region with the output.
3759 0 : (progn (setq buffer-read-only nil)
3760 0 : (delete-region (max start end) (point-max))
3761 0 : (delete-region (point-min) (min start end))
3762 0 : (setq exit-status
3763 0 : (call-process-region (point-min) (point-max)
3764 0 : shell-file-name t
3765 0 : (if error-file
3766 0 : (list t error-file)
3767 0 : t)
3768 0 : nil shell-command-switch
3769 0 : command)))
3770 : ;; Clear the output buffer, then run the command with
3771 : ;; output there.
3772 0 : (let ((directory default-directory))
3773 0 : (with-current-buffer buffer
3774 0 : (if (not output-buffer)
3775 0 : (setq default-directory directory))
3776 0 : (shell-command--save-pos-or-erase)))
3777 0 : (setq exit-status
3778 0 : (call-shell-region start end command nil
3779 0 : (if error-file
3780 0 : (list buffer error-file)
3781 0 : buffer))))
3782 : ;; Report the output.
3783 0 : (with-current-buffer buffer
3784 0 : (setq mode-line-process
3785 0 : (cond ((null exit-status)
3786 : " - Error")
3787 0 : ((stringp exit-status)
3788 0 : (format " - Signal [%s]" exit-status))
3789 0 : ((not (equal 0 exit-status))
3790 0 : (format " - Exit [%d]" exit-status)))))
3791 0 : (if (with-current-buffer buffer (> (point-max) (point-min)))
3792 : ;; There's some output, display it
3793 0 : (progn
3794 0 : (display-message-or-buffer buffer)
3795 0 : (shell-command--set-point-after-cmd buffer))
3796 : ;; No output; error?
3797 0 : (let ((output
3798 0 : (if (and error-file
3799 0 : (< 0 (nth 7 (file-attributes error-file))))
3800 0 : (format "some error output%s"
3801 0 : (if shell-command-default-error-buffer
3802 0 : (format " to the \"%s\" buffer"
3803 0 : shell-command-default-error-buffer)
3804 0 : ""))
3805 0 : "no output")))
3806 0 : (cond ((null exit-status)
3807 0 : (message "(Shell command failed with error)"))
3808 0 : ((equal 0 exit-status)
3809 0 : (message "(Shell command succeeded with %s)"
3810 0 : output))
3811 0 : ((stringp exit-status)
3812 0 : (message "(Shell command killed by signal %s)"
3813 0 : exit-status))
3814 : (t
3815 0 : (message "(Shell command failed with code %d and %s)"
3816 0 : exit-status output))))
3817 : ;; Don't kill: there might be useful info in the undo-log.
3818 : ;; (kill-buffer buffer)
3819 0 : )))))
3820 :
3821 0 : (when (and error-file (file-exists-p error-file))
3822 0 : (if (< 0 (nth 7 (file-attributes error-file)))
3823 0 : (with-current-buffer (get-buffer-create error-buffer)
3824 0 : (let ((pos-from-end (- (point-max) (point))))
3825 0 : (or (bobp)
3826 0 : (insert "\f\n"))
3827 : ;; Do no formatting while reading error file,
3828 : ;; because that can run a shell command, and we
3829 : ;; don't want that to cause an infinite recursion.
3830 0 : (format-insert-file error-file nil)
3831 : ;; Put point after the inserted errors.
3832 0 : (goto-char (- (point-max) pos-from-end)))
3833 0 : (and display-error-buffer
3834 0 : (display-buffer (current-buffer)))))
3835 0 : (delete-file error-file))
3836 0 : exit-status))
3837 :
3838 : (defun shell-command-to-string (command)
3839 : "Execute shell command COMMAND and return its output as a string."
3840 11 : (with-output-to-string
3841 11 : (with-current-buffer
3842 11 : standard-output
3843 11 : (process-file shell-file-name nil t nil shell-command-switch command))))
3844 :
3845 : (defun process-file (program &optional infile buffer display &rest args)
3846 : "Process files synchronously in a separate process.
3847 : Similar to `call-process', but may invoke a file handler based on
3848 : `default-directory'. The current working directory of the
3849 : subprocess is `default-directory'.
3850 :
3851 : File names in INFILE and BUFFER are handled normally, but file
3852 : names in ARGS should be relative to `default-directory', as they
3853 : are passed to the process verbatim. (This is a difference to
3854 : `call-process' which does not support file handlers for INFILE
3855 : and BUFFER.)
3856 :
3857 : Some file handlers might not support all variants, for example
3858 : they might behave as if DISPLAY was nil, regardless of the actual
3859 : value passed."
3860 732 : (let ((fh (find-file-name-handler default-directory 'process-file))
3861 : lc stderr-file)
3862 732 : (unwind-protect
3863 732 : (if fh (apply fh 'process-file program infile buffer display args)
3864 630 : (when infile (setq lc (file-local-copy infile)))
3865 630 : (setq stderr-file (when (and (consp buffer) (stringp (cadr buffer)))
3866 630 : (make-temp-file "emacs")))
3867 630 : (prog1
3868 630 : (apply 'call-process program
3869 630 : (or lc infile)
3870 630 : (if stderr-file (list (car buffer) stderr-file) buffer)
3871 630 : display args)
3872 732 : (when stderr-file (copy-file stderr-file (cadr buffer) t))))
3873 732 : (when stderr-file (delete-file stderr-file))
3874 732 : (when lc (delete-file lc)))))
3875 :
3876 : (defvar process-file-side-effects t
3877 : "Whether a call of `process-file' changes remote files.
3878 :
3879 : By default, this variable is always set to t, meaning that a
3880 : call of `process-file' could potentially change any file on a
3881 : remote host. When set to nil, a file handler could optimize
3882 : its behavior with respect to remote file attribute caching.
3883 :
3884 : You should only ever change this variable with a let-binding;
3885 : never with `setq'.")
3886 :
3887 : (defun start-file-process (name buffer program &rest program-args)
3888 : "Start a program in a subprocess. Return the process object for it.
3889 :
3890 : Similar to `start-process', but may invoke a file handler based on
3891 : `default-directory'. See Info node `(elisp)Magic File Names'.
3892 :
3893 : This handler ought to run PROGRAM, perhaps on the local host,
3894 : perhaps on a remote host that corresponds to `default-directory'.
3895 : In the latter case, the local part of `default-directory' becomes
3896 : the working directory of the process.
3897 :
3898 : PROGRAM and PROGRAM-ARGS might be file names. They are not
3899 : objects of file handler invocation. File handlers might not
3900 : support pty association, if PROGRAM is nil."
3901 27 : (let ((fh (find-file-name-handler default-directory 'start-file-process)))
3902 27 : (if fh (apply fh 'start-file-process name buffer program program-args)
3903 27 : (apply 'start-process name buffer program program-args))))
3904 :
3905 : ;;;; Process menu
3906 :
3907 : (defvar tabulated-list-format)
3908 : (defvar tabulated-list-entries)
3909 : (defvar tabulated-list-sort-key)
3910 : (declare-function tabulated-list-init-header "tabulated-list" ())
3911 : (declare-function tabulated-list-print "tabulated-list"
3912 : (&optional remember-pos update))
3913 :
3914 : (defvar process-menu-query-only nil)
3915 :
3916 : (defvar process-menu-mode-map
3917 : (let ((map (make-sparse-keymap)))
3918 : (define-key map [?d] 'process-menu-delete-process)
3919 : map))
3920 :
3921 : (define-derived-mode process-menu-mode tabulated-list-mode "Process Menu"
3922 : "Major mode for listing the processes called by Emacs."
3923 0 : (setq tabulated-list-format [("Process" 15 t)
3924 : ("PID" 7 t)
3925 : ("Status" 7 t)
3926 : ("Buffer" 15 t)
3927 : ("TTY" 12 t)
3928 0 : ("Command" 0 t)])
3929 0 : (make-local-variable 'process-menu-query-only)
3930 0 : (setq tabulated-list-sort-key (cons "Process" nil))
3931 0 : (add-hook 'tabulated-list-revert-hook 'list-processes--refresh nil t))
3932 :
3933 : (defun process-menu-delete-process ()
3934 : "Kill process at point in a `list-processes' buffer."
3935 : (interactive)
3936 0 : (let ((pos (point)))
3937 0 : (delete-process (tabulated-list-get-id))
3938 0 : (revert-buffer)
3939 0 : (goto-char (min pos (point-max)))
3940 0 : (if (eobp)
3941 0 : (forward-line -1)
3942 0 : (beginning-of-line))))
3943 :
3944 : (defun list-processes--refresh ()
3945 : "Recompute the list of processes for the Process List buffer.
3946 : Also, delete any process that is exited or signaled."
3947 0 : (setq tabulated-list-entries nil)
3948 0 : (dolist (p (process-list))
3949 0 : (cond ((memq (process-status p) '(exit signal closed))
3950 0 : (delete-process p))
3951 0 : ((or (not process-menu-query-only)
3952 0 : (process-query-on-exit-flag p))
3953 0 : (let* ((buf (process-buffer p))
3954 0 : (type (process-type p))
3955 0 : (pid (if (process-id p) (format "%d" (process-id p)) "--"))
3956 0 : (name (process-name p))
3957 0 : (status (symbol-name (process-status p)))
3958 0 : (buf-label (if (buffer-live-p buf)
3959 0 : `(,(buffer-name buf)
3960 : face link
3961 0 : help-echo ,(format-message
3962 : "Visit buffer `%s'"
3963 0 : (buffer-name buf))
3964 : follow-link t
3965 0 : process-buffer ,buf
3966 0 : action process-menu-visit-buffer)
3967 0 : "--"))
3968 0 : (tty (or (process-tty-name p) "--"))
3969 : (cmd
3970 0 : (if (memq type '(network serial))
3971 0 : (let ((contact (process-contact p t)))
3972 0 : (if (eq type 'network)
3973 0 : (format "(%s %s)"
3974 0 : (if (plist-get contact :type)
3975 : "datagram"
3976 0 : "network")
3977 0 : (if (plist-get contact :server)
3978 0 : (format "server on %s"
3979 0 : (or
3980 0 : (plist-get contact :host)
3981 0 : (plist-get contact :local)))
3982 0 : (format "connection to %s"
3983 0 : (plist-get contact :host))))
3984 0 : (format "(serial port %s%s)"
3985 0 : (or (plist-get contact :port) "?")
3986 0 : (let ((speed (plist-get contact :speed)))
3987 0 : (if speed
3988 0 : (format " at %s b/s" speed)
3989 0 : "")))))
3990 0 : (mapconcat 'identity (process-command p) " "))))
3991 0 : (push (list p (vector name pid status buf-label tty cmd))
3992 0 : tabulated-list-entries)))))
3993 0 : (tabulated-list-init-header))
3994 :
3995 : (defun process-menu-visit-buffer (button)
3996 0 : (display-buffer (button-get button 'process-buffer)))
3997 :
3998 : (defun list-processes (&optional query-only buffer)
3999 : "Display a list of all processes that are Emacs sub-processes.
4000 : If optional argument QUERY-ONLY is non-nil, only processes with
4001 : the query-on-exit flag set are listed.
4002 : Any process listed as exited or signaled is actually eliminated
4003 : after the listing is made.
4004 : Optional argument BUFFER specifies a buffer to use, instead of
4005 : \"*Process List*\".
4006 : The return value is always nil.
4007 :
4008 : This function lists only processes that were launched by Emacs. To
4009 : see other processes running on the system, use `list-system-processes'."
4010 : (interactive)
4011 0 : (or (fboundp 'process-list)
4012 0 : (error "Asynchronous subprocesses are not supported on this system"))
4013 0 : (unless (bufferp buffer)
4014 0 : (setq buffer (get-buffer-create "*Process List*")))
4015 0 : (with-current-buffer buffer
4016 0 : (process-menu-mode)
4017 0 : (setq process-menu-query-only query-only)
4018 0 : (list-processes--refresh)
4019 0 : (tabulated-list-print))
4020 0 : (display-buffer buffer)
4021 : nil)
4022 :
4023 : ;;;; Prefix commands
4024 :
4025 : (setq prefix-command--needs-update nil)
4026 : (setq prefix-command--last-echo nil)
4027 :
4028 : (defun internal-echo-keystrokes-prefix ()
4029 : ;; BEWARE: Called directly from C code.
4030 : ;; If the return value is non-nil, it means we are in the middle of
4031 : ;; a command with prefix, such as a command invoked with prefix-arg.
4032 0 : (if (not prefix-command--needs-update)
4033 0 : prefix-command--last-echo
4034 0 : (setq prefix-command--last-echo
4035 0 : (let ((strs nil))
4036 0 : (run-hook-wrapped 'prefix-command-echo-keystrokes-functions
4037 0 : (lambda (fun) (push (funcall fun) strs)))
4038 0 : (setq strs (delq nil strs))
4039 0 : (when strs (mapconcat #'identity strs " "))))))
4040 :
4041 : (defvar prefix-command-echo-keystrokes-functions nil
4042 : "Abnormal hook which constructs the description of the current prefix state.
4043 : Each function is called with no argument, should return a string or nil.")
4044 :
4045 : (defun prefix-command-update ()
4046 : "Update state of prefix commands.
4047 : Call it whenever you change the \"prefix command state\"."
4048 0 : (setq prefix-command--needs-update t))
4049 :
4050 : (defvar prefix-command-preserve-state-hook nil
4051 : "Normal hook run when a command needs to preserve the prefix.")
4052 :
4053 : (defun prefix-command-preserve-state ()
4054 : "Pass the current prefix command state to the next command.
4055 : Should be called by all prefix commands.
4056 : Runs `prefix-command-preserve-state-hook'."
4057 0 : (run-hooks 'prefix-command-preserve-state-hook)
4058 : ;; If the current command is a prefix command, we don't want the next (real)
4059 : ;; command to have `last-command' set to, say, `universal-argument'.
4060 0 : (setq this-command last-command)
4061 0 : (setq real-this-command real-last-command)
4062 0 : (prefix-command-update))
4063 :
4064 : (defun reset-this-command-lengths ()
4065 : (declare (obsolete prefix-command-preserve-state "25.1"))
4066 : nil)
4067 :
4068 : ;;;;; The main prefix command.
4069 :
4070 : ;; FIXME: Declaration of `prefix-arg' should be moved here!?
4071 :
4072 : (add-hook 'prefix-command-echo-keystrokes-functions
4073 : #'universal-argument--description)
4074 : (defun universal-argument--description ()
4075 0 : (when prefix-arg
4076 0 : (concat "C-u"
4077 0 : (pcase prefix-arg
4078 : (`(-) " -")
4079 : (`(,(and (pred integerp) n))
4080 0 : (let ((str ""))
4081 0 : (while (and (> n 4) (= (mod n 4) 0))
4082 0 : (setq str (concat str " C-u"))
4083 0 : (setq n (/ n 4)))
4084 0 : (if (= n 4) str (format " %s" prefix-arg))))
4085 0 : (_ (format " %s" prefix-arg))))))
4086 :
4087 : (add-hook 'prefix-command-preserve-state-hook
4088 : #'universal-argument--preserve)
4089 : (defun universal-argument--preserve ()
4090 0 : (setq prefix-arg current-prefix-arg))
4091 :
4092 : (defvar universal-argument-map
4093 : (let ((map (make-sparse-keymap))
4094 : (universal-argument-minus
4095 : ;; For backward compatibility, minus with no modifiers is an ordinary
4096 : ;; command if digits have already been entered.
4097 : `(menu-item "" negative-argument
4098 : :filter ,(lambda (cmd)
4099 : (if (integerp prefix-arg) nil cmd)))))
4100 : (define-key map [switch-frame]
4101 : (lambda (e) (interactive "e")
4102 : (handle-switch-frame e) (universal-argument--mode)))
4103 : (define-key map [?\C-u] 'universal-argument-more)
4104 : (define-key map [?-] universal-argument-minus)
4105 : (define-key map [?0] 'digit-argument)
4106 : (define-key map [?1] 'digit-argument)
4107 : (define-key map [?2] 'digit-argument)
4108 : (define-key map [?3] 'digit-argument)
4109 : (define-key map [?4] 'digit-argument)
4110 : (define-key map [?5] 'digit-argument)
4111 : (define-key map [?6] 'digit-argument)
4112 : (define-key map [?7] 'digit-argument)
4113 : (define-key map [?8] 'digit-argument)
4114 : (define-key map [?9] 'digit-argument)
4115 : (define-key map [kp-0] 'digit-argument)
4116 : (define-key map [kp-1] 'digit-argument)
4117 : (define-key map [kp-2] 'digit-argument)
4118 : (define-key map [kp-3] 'digit-argument)
4119 : (define-key map [kp-4] 'digit-argument)
4120 : (define-key map [kp-5] 'digit-argument)
4121 : (define-key map [kp-6] 'digit-argument)
4122 : (define-key map [kp-7] 'digit-argument)
4123 : (define-key map [kp-8] 'digit-argument)
4124 : (define-key map [kp-9] 'digit-argument)
4125 : (define-key map [kp-subtract] universal-argument-minus)
4126 : map)
4127 : "Keymap used while processing \\[universal-argument].")
4128 :
4129 : (defun universal-argument--mode ()
4130 0 : (prefix-command-update)
4131 0 : (set-transient-map universal-argument-map nil))
4132 :
4133 : (defun universal-argument ()
4134 : "Begin a numeric argument for the following command.
4135 : Digits or minus sign following \\[universal-argument] make up the numeric argument.
4136 : \\[universal-argument] following the digits or minus sign ends the argument.
4137 : \\[universal-argument] without digits or minus sign provides 4 as argument.
4138 : Repeating \\[universal-argument] without digits or minus sign
4139 : multiplies the argument by 4 each time.
4140 : For some commands, just \\[universal-argument] by itself serves as a flag
4141 : which is different in effect from any particular numeric argument.
4142 : These commands include \\[set-mark-command] and \\[start-kbd-macro]."
4143 : (interactive)
4144 0 : (prefix-command-preserve-state)
4145 0 : (setq prefix-arg (list 4))
4146 0 : (universal-argument--mode))
4147 :
4148 : (defun universal-argument-more (arg)
4149 : ;; A subsequent C-u means to multiply the factor by 4 if we've typed
4150 : ;; nothing but C-u's; otherwise it means to terminate the prefix arg.
4151 : (interactive "P")
4152 0 : (prefix-command-preserve-state)
4153 0 : (setq prefix-arg (if (consp arg)
4154 0 : (list (* 4 (car arg)))
4155 0 : (if (eq arg '-)
4156 0 : (list -4)
4157 0 : arg)))
4158 0 : (when (consp prefix-arg) (universal-argument--mode)))
4159 :
4160 : (defun negative-argument (arg)
4161 : "Begin a negative numeric argument for the next command.
4162 : \\[universal-argument] following digits or minus sign ends the argument."
4163 : (interactive "P")
4164 0 : (prefix-command-preserve-state)
4165 0 : (setq prefix-arg (cond ((integerp arg) (- arg))
4166 0 : ((eq arg '-) nil)
4167 0 : (t '-)))
4168 0 : (universal-argument--mode))
4169 :
4170 : (defun digit-argument (arg)
4171 : "Part of the numeric argument for the next command.
4172 : \\[universal-argument] following digits or minus sign ends the argument."
4173 : (interactive "P")
4174 0 : (prefix-command-preserve-state)
4175 0 : (let* ((char (if (integerp last-command-event)
4176 0 : last-command-event
4177 0 : (get last-command-event 'ascii-character)))
4178 0 : (digit (- (logand char ?\177) ?0)))
4179 0 : (setq prefix-arg (cond ((integerp arg)
4180 0 : (+ (* arg 10)
4181 0 : (if (< arg 0) (- digit) digit)))
4182 0 : ((eq arg '-)
4183 : ;; Treat -0 as just -, so that -01 will work.
4184 0 : (if (zerop digit) '- (- digit)))
4185 : (t
4186 0 : digit))))
4187 0 : (universal-argument--mode))
4188 :
4189 :
4190 : (defvar filter-buffer-substring-functions nil
4191 : "This variable is a wrapper hook around `buffer-substring--filter'.
4192 : \(See `with-wrapper-hook' for details about wrapper hooks.)")
4193 : (make-obsolete-variable 'filter-buffer-substring-functions
4194 : 'filter-buffer-substring-function "24.4")
4195 :
4196 : (defvar filter-buffer-substring-function #'buffer-substring--filter
4197 : "Function to perform the filtering in `filter-buffer-substring'.
4198 : The function is called with the same 3 arguments (BEG END DELETE)
4199 : that `filter-buffer-substring' received. It should return the
4200 : buffer substring between BEG and END, after filtering. If DELETE is
4201 : non-nil, it should delete the text between BEG and END from the buffer.")
4202 :
4203 : (defvar buffer-substring-filters nil
4204 : "List of filter functions for `buffer-substring--filter'.
4205 : Each function must accept a single argument, a string, and return a string.
4206 : The buffer substring is passed to the first function in the list,
4207 : and the return value of each function is passed to the next.
4208 : As a special convention, point is set to the start of the buffer text
4209 : being operated on (i.e., the first argument of `buffer-substring--filter')
4210 : before these functions are called.")
4211 : (make-obsolete-variable 'buffer-substring-filters
4212 : 'filter-buffer-substring-function "24.1")
4213 :
4214 : (defun filter-buffer-substring (beg end &optional delete)
4215 : "Return the buffer substring between BEG and END, after filtering.
4216 : If DELETE is non-nil, delete the text between BEG and END from the buffer.
4217 :
4218 : This calls the function that `filter-buffer-substring-function' specifies
4219 : \(passing the same three arguments that it received) to do the work,
4220 : and returns whatever it does. The default function does no filtering,
4221 : unless a hook has been set.
4222 :
4223 : Use `filter-buffer-substring' instead of `buffer-substring',
4224 : `buffer-substring-no-properties', or `delete-and-extract-region' when
4225 : you want to allow filtering to take place. For example, major or minor
4226 : modes can use `filter-buffer-substring-function' to extract characters
4227 : that are special to a buffer, and should not be copied into other buffers."
4228 0 : (funcall filter-buffer-substring-function beg end delete))
4229 :
4230 : (defun buffer-substring--filter (beg end &optional delete)
4231 : "Default function to use for `filter-buffer-substring-function'.
4232 : Its arguments and return value are as specified for `filter-buffer-substring'.
4233 : Also respects the obsolete wrapper hook `filter-buffer-substring-functions'
4234 : \(see `with-wrapper-hook' for details about wrapper hooks),
4235 : and the abnormal hook `buffer-substring-filters'.
4236 : No filtering is done unless a hook says to."
4237 0 : (subr--with-wrapper-hook-no-warnings
4238 : filter-buffer-substring-functions (beg end delete)
4239 : (cond
4240 : ((or delete buffer-substring-filters)
4241 : (save-excursion
4242 : (goto-char beg)
4243 : (let ((string (if delete (delete-and-extract-region beg end)
4244 : (buffer-substring beg end))))
4245 : (dolist (filter buffer-substring-filters)
4246 : (setq string (funcall filter string)))
4247 : string)))
4248 : (t
4249 0 : (buffer-substring beg end)))))
4250 :
4251 :
4252 : ;;;; Window system cut and paste hooks.
4253 :
4254 : (defvar interprogram-cut-function #'gui-select-text
4255 : "Function to call to make a killed region available to other programs.
4256 : Most window systems provide a facility for cutting and pasting
4257 : text between different programs, such as the clipboard on X and
4258 : MS-Windows, or the pasteboard on Nextstep/Mac OS.
4259 :
4260 : This variable holds a function that Emacs calls whenever text is
4261 : put in the kill ring, to make the new kill available to other
4262 : programs. The function takes one argument, TEXT, which is a
4263 : string containing the text which should be made available.")
4264 :
4265 : (defvar interprogram-paste-function #'gui-selection-value
4266 : "Function to call to get text cut from other programs.
4267 : Most window systems provide a facility for cutting and pasting
4268 : text between different programs, such as the clipboard on X and
4269 : MS-Windows, or the pasteboard on Nextstep/Mac OS.
4270 :
4271 : This variable holds a function that Emacs calls to obtain text
4272 : that other programs have provided for pasting. The function is
4273 : called with no arguments. If no other program has provided text
4274 : to paste, the function should return nil (in which case the
4275 : caller, usually `current-kill', should use the top of the Emacs
4276 : kill ring). If another program has provided text to paste, the
4277 : function should return that text as a string (in which case the
4278 : caller should put this string in the kill ring as the latest
4279 : kill).
4280 :
4281 : The function may also return a list of strings if the window
4282 : system supports multiple selections. The first string will be
4283 : used as the pasted text, but the other will be placed in the kill
4284 : ring for easy access via `yank-pop'.
4285 :
4286 : Note that the function should return a string only if a program
4287 : other than Emacs has provided a string for pasting; if Emacs
4288 : provided the most recent string, the function should return nil.
4289 : If it is difficult to tell whether Emacs or some other program
4290 : provided the current string, it is probably good enough to return
4291 : nil if the string is equal (according to `string=') to the last
4292 : text Emacs provided.")
4293 :
4294 :
4295 :
4296 : ;;;; The kill ring data structure.
4297 :
4298 : (defvar kill-ring nil
4299 : "List of killed text sequences.
4300 : Since the kill ring is supposed to interact nicely with cut-and-paste
4301 : facilities offered by window systems, use of this variable should
4302 : interact nicely with `interprogram-cut-function' and
4303 : `interprogram-paste-function'. The functions `kill-new',
4304 : `kill-append', and `current-kill' are supposed to implement this
4305 : interaction; you may want to use them instead of manipulating the kill
4306 : ring directly.")
4307 :
4308 : (defcustom kill-ring-max 60
4309 : "Maximum length of kill ring before oldest elements are thrown away."
4310 : :type 'integer
4311 : :group 'killing)
4312 :
4313 : (defvar kill-ring-yank-pointer nil
4314 : "The tail of the kill ring whose car is the last thing yanked.")
4315 :
4316 : (defcustom save-interprogram-paste-before-kill nil
4317 : "Save clipboard strings into kill ring before replacing them.
4318 : When one selects something in another program to paste it into Emacs,
4319 : but kills something in Emacs before actually pasting it,
4320 : this selection is gone unless this variable is non-nil,
4321 : in which case the other program's selection is saved in the `kill-ring'
4322 : before the Emacs kill and one can still paste it using \\[yank] \\[yank-pop]."
4323 : :type 'boolean
4324 : :group 'killing
4325 : :version "23.2")
4326 :
4327 : (defcustom kill-do-not-save-duplicates nil
4328 : "Do not add a new string to `kill-ring' if it duplicates the last one.
4329 : The comparison is done using `equal-including-properties'."
4330 : :type 'boolean
4331 : :group 'killing
4332 : :version "23.2")
4333 :
4334 : (defun kill-new (string &optional replace)
4335 : "Make STRING the latest kill in the kill ring.
4336 : Set `kill-ring-yank-pointer' to point to it.
4337 : If `interprogram-cut-function' is non-nil, apply it to STRING.
4338 : Optional second argument REPLACE non-nil means that STRING will replace
4339 : the front of the kill ring, rather than being added to the list.
4340 :
4341 : When `save-interprogram-paste-before-kill' and `interprogram-paste-function'
4342 : are non-nil, saves the interprogram paste string(s) into `kill-ring' before
4343 : STRING.
4344 :
4345 : When the yank handler has a non-nil PARAM element, the original STRING
4346 : argument is not used by `insert-for-yank'. However, since Lisp code
4347 : may access and use elements from the kill ring directly, the STRING
4348 : argument should still be a \"useful\" string for such uses."
4349 0 : (unless (and kill-do-not-save-duplicates
4350 : ;; Due to text properties such as 'yank-handler that
4351 : ;; can alter the contents to yank, comparison using
4352 : ;; `equal' is unsafe.
4353 0 : (equal-including-properties string (car kill-ring)))
4354 0 : (if (fboundp 'menu-bar-update-yank-menu)
4355 0 : (menu-bar-update-yank-menu string (and replace (car kill-ring)))))
4356 0 : (when save-interprogram-paste-before-kill
4357 0 : (let ((interprogram-paste (and interprogram-paste-function
4358 0 : (funcall interprogram-paste-function))))
4359 0 : (when interprogram-paste
4360 0 : (dolist (s (if (listp interprogram-paste)
4361 0 : (nreverse interprogram-paste)
4362 0 : (list interprogram-paste)))
4363 0 : (unless (and kill-do-not-save-duplicates
4364 0 : (equal-including-properties s (car kill-ring)))
4365 0 : (push s kill-ring))))))
4366 0 : (unless (and kill-do-not-save-duplicates
4367 0 : (equal-including-properties string (car kill-ring)))
4368 0 : (if (and replace kill-ring)
4369 0 : (setcar kill-ring string)
4370 0 : (push string kill-ring)
4371 0 : (if (> (length kill-ring) kill-ring-max)
4372 0 : (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))))
4373 0 : (setq kill-ring-yank-pointer kill-ring)
4374 0 : (if interprogram-cut-function
4375 0 : (funcall interprogram-cut-function string)))
4376 :
4377 : ;; It has been argued that this should work similar to `self-insert-command'
4378 : ;; which merges insertions in undo-list in groups of 20 (hard-coded in cmds.c).
4379 : (defcustom kill-append-merge-undo nil
4380 : "Whether appending to kill ring also makes \\[undo] restore both pieces of text simultaneously."
4381 : :type 'boolean
4382 : :group 'killing
4383 : :version "25.1")
4384 :
4385 : (defun kill-append (string before-p)
4386 : "Append STRING to the end of the latest kill in the kill ring.
4387 : If BEFORE-P is non-nil, prepend STRING to the kill.
4388 : Also removes the last undo boundary in the current buffer,
4389 : depending on `kill-append-merge-undo'.
4390 : If `interprogram-cut-function' is set, pass the resulting kill to it."
4391 0 : (let* ((cur (car kill-ring)))
4392 0 : (kill-new (if before-p (concat string cur) (concat cur string))
4393 0 : (or (= (length cur) 0)
4394 0 : (equal nil (get-text-property 0 'yank-handler cur))))
4395 0 : (when (and kill-append-merge-undo (not buffer-read-only))
4396 0 : (let ((prev buffer-undo-list)
4397 0 : (next (cdr buffer-undo-list)))
4398 : ;; find the next undo boundary
4399 0 : (while (car next)
4400 0 : (pop next)
4401 0 : (pop prev))
4402 : ;; remove this undo boundary
4403 0 : (when prev
4404 0 : (setcdr prev (cdr next)))))))
4405 :
4406 : (defcustom yank-pop-change-selection nil
4407 : "Whether rotating the kill ring changes the window system selection.
4408 : If non-nil, whenever the kill ring is rotated (usually via the
4409 : `yank-pop' command), Emacs also calls `interprogram-cut-function'
4410 : to copy the new kill to the window system selection."
4411 : :type 'boolean
4412 : :group 'killing
4413 : :version "23.1")
4414 :
4415 : (defun current-kill (n &optional do-not-move)
4416 : "Rotate the yanking point by N places, and then return that kill.
4417 : If N is zero and `interprogram-paste-function' is set to a
4418 : function that returns a string or a list of strings, and if that
4419 : function doesn't return nil, then that string (or list) is added
4420 : to the front of the kill ring and the string (or first string in
4421 : the list) is returned as the latest kill.
4422 :
4423 : If N is not zero, and if `yank-pop-change-selection' is
4424 : non-nil, use `interprogram-cut-function' to transfer the
4425 : kill at the new yank point into the window system selection.
4426 :
4427 : If optional arg DO-NOT-MOVE is non-nil, then don't actually
4428 : move the yanking point; just return the Nth kill forward."
4429 :
4430 0 : (let ((interprogram-paste (and (= n 0)
4431 0 : interprogram-paste-function
4432 0 : (funcall interprogram-paste-function))))
4433 0 : (if interprogram-paste
4434 0 : (progn
4435 : ;; Disable the interprogram cut function when we add the new
4436 : ;; text to the kill ring, so Emacs doesn't try to own the
4437 : ;; selection, with identical text.
4438 0 : (let ((interprogram-cut-function nil))
4439 0 : (if (listp interprogram-paste)
4440 0 : (mapc 'kill-new (nreverse interprogram-paste))
4441 0 : (kill-new interprogram-paste)))
4442 0 : (car kill-ring))
4443 0 : (or kill-ring (error "Kill ring is empty"))
4444 0 : (let ((ARGth-kill-element
4445 0 : (nthcdr (mod (- n (length kill-ring-yank-pointer))
4446 0 : (length kill-ring))
4447 0 : kill-ring)))
4448 0 : (unless do-not-move
4449 0 : (setq kill-ring-yank-pointer ARGth-kill-element)
4450 0 : (when (and yank-pop-change-selection
4451 0 : (> n 0)
4452 0 : interprogram-cut-function)
4453 0 : (funcall interprogram-cut-function (car ARGth-kill-element))))
4454 0 : (car ARGth-kill-element)))))
4455 :
4456 :
4457 :
4458 : ;;;; Commands for manipulating the kill ring.
4459 :
4460 : (defcustom kill-read-only-ok nil
4461 : "Non-nil means don't signal an error for killing read-only text."
4462 : :type 'boolean
4463 : :group 'killing)
4464 :
4465 : (defun kill-region (beg end &optional region)
4466 : "Kill (\"cut\") text between point and mark.
4467 : This deletes the text from the buffer and saves it in the kill ring.
4468 : The command \\[yank] can retrieve it from there.
4469 : \(If you want to save the region without killing it, use \\[kill-ring-save].)
4470 :
4471 : If you want to append the killed region to the last killed text,
4472 : use \\[append-next-kill] before \\[kill-region].
4473 :
4474 : Any command that calls this function is a \"kill command\".
4475 : If the previous command was also a kill command,
4476 : the text killed this time appends to the text killed last time
4477 : to make one entry in the kill ring.
4478 :
4479 : The killed text is filtered by `filter-buffer-substring' before it is
4480 : saved in the kill ring, so the actual saved text might be different
4481 : from what was killed.
4482 :
4483 : If the buffer is read-only, Emacs will beep and refrain from deleting
4484 : the text, but put the text in the kill ring anyway. This means that
4485 : you can use the killing commands to copy text from a read-only buffer.
4486 :
4487 : Lisp programs should use this function for killing text.
4488 : (To delete text, use `delete-region'.)
4489 : Supply two arguments, character positions BEG and END indicating the
4490 : stretch of text to be killed. If the optional argument REGION is
4491 : non-nil, the function ignores BEG and END, and kills the current
4492 : region instead."
4493 : ;; Pass mark first, then point, because the order matters when
4494 : ;; calling `kill-append'.
4495 0 : (interactive (list (mark) (point) 'region))
4496 0 : (unless (and beg end)
4497 0 : (user-error "The mark is not set now, so there is no region"))
4498 0 : (condition-case nil
4499 0 : (let ((string (if region
4500 0 : (funcall region-extract-function 'delete)
4501 0 : (filter-buffer-substring beg end 'delete))))
4502 0 : (when string ;STRING is nil if BEG = END
4503 : ;; Add that string to the kill ring, one way or another.
4504 0 : (if (eq last-command 'kill-region)
4505 0 : (kill-append string (< end beg))
4506 0 : (kill-new string)))
4507 0 : (when (or string (eq last-command 'kill-region))
4508 0 : (setq this-command 'kill-region))
4509 0 : (setq deactivate-mark t)
4510 0 : nil)
4511 : ((buffer-read-only text-read-only)
4512 : ;; The code above failed because the buffer, or some of the characters
4513 : ;; in the region, are read-only.
4514 : ;; We should beep, in case the user just isn't aware of this.
4515 : ;; However, there's no harm in putting
4516 : ;; the region's text in the kill ring, anyway.
4517 0 : (copy-region-as-kill beg end region)
4518 : ;; Set this-command now, so it will be set even if we get an error.
4519 0 : (setq this-command 'kill-region)
4520 : ;; This should barf, if appropriate, and give us the correct error.
4521 0 : (if kill-read-only-ok
4522 0 : (progn (message "Read only text copied to kill ring") nil)
4523 : ;; Signal an error if the buffer is read-only.
4524 0 : (barf-if-buffer-read-only)
4525 : ;; If the buffer isn't read-only, the text is.
4526 0 : (signal 'text-read-only (list (current-buffer)))))))
4527 :
4528 : ;; copy-region-as-kill no longer sets this-command, because it's confusing
4529 : ;; to get two copies of the text when the user accidentally types M-w and
4530 : ;; then corrects it with the intended C-w.
4531 : (defun copy-region-as-kill (beg end &optional region)
4532 : "Save the region as if killed, but don't kill it.
4533 : In Transient Mark mode, deactivate the mark.
4534 : If `interprogram-cut-function' is non-nil, also save the text for a window
4535 : system cut and paste.
4536 :
4537 : The copied text is filtered by `filter-buffer-substring' before it is
4538 : saved in the kill ring, so the actual saved text might be different
4539 : from what was in the buffer.
4540 :
4541 : When called from Lisp, save in the kill ring the stretch of text
4542 : between BEG and END, unless the optional argument REGION is
4543 : non-nil, in which case ignore BEG and END, and save the current
4544 : region instead.
4545 :
4546 : This command's old key binding has been given to `kill-ring-save'."
4547 : ;; Pass mark first, then point, because the order matters when
4548 : ;; calling `kill-append'.
4549 0 : (interactive (list (mark) (point)
4550 0 : (prefix-numeric-value current-prefix-arg)))
4551 0 : (let ((str (if region
4552 0 : (funcall region-extract-function nil)
4553 0 : (filter-buffer-substring beg end))))
4554 0 : (if (eq last-command 'kill-region)
4555 0 : (kill-append str (< end beg))
4556 0 : (kill-new str)))
4557 0 : (setq deactivate-mark t)
4558 : nil)
4559 :
4560 : (defun kill-ring-save (beg end &optional region)
4561 : "Save the region as if killed, but don't kill it.
4562 : In Transient Mark mode, deactivate the mark.
4563 : If `interprogram-cut-function' is non-nil, also save the text for a window
4564 : system cut and paste.
4565 :
4566 : If you want to append the killed line to the last killed text,
4567 : use \\[append-next-kill] before \\[kill-ring-save].
4568 :
4569 : The copied text is filtered by `filter-buffer-substring' before it is
4570 : saved in the kill ring, so the actual saved text might be different
4571 : from what was in the buffer.
4572 :
4573 : When called from Lisp, save in the kill ring the stretch of text
4574 : between BEG and END, unless the optional argument REGION is
4575 : non-nil, in which case ignore BEG and END, and save the current
4576 : region instead.
4577 :
4578 : This command is similar to `copy-region-as-kill', except that it gives
4579 : visual feedback indicating the extent of the region being copied."
4580 : ;; Pass mark first, then point, because the order matters when
4581 : ;; calling `kill-append'.
4582 0 : (interactive (list (mark) (point)
4583 0 : (prefix-numeric-value current-prefix-arg)))
4584 0 : (copy-region-as-kill beg end region)
4585 : ;; This use of called-interactively-p is correct because the code it
4586 : ;; controls just gives the user visual feedback.
4587 0 : (if (called-interactively-p 'interactive)
4588 0 : (indicate-copied-region)))
4589 :
4590 : (defun indicate-copied-region (&optional message-len)
4591 : "Indicate that the region text has been copied interactively.
4592 : If the mark is visible in the selected window, blink the cursor
4593 : between point and mark if there is currently no active region
4594 : highlighting.
4595 :
4596 : If the mark lies outside the selected window, display an
4597 : informative message containing a sample of the copied text. The
4598 : optional argument MESSAGE-LEN, if non-nil, specifies the length
4599 : of this sample text; it defaults to 40."
4600 0 : (let ((mark (mark t))
4601 0 : (point (point))
4602 : ;; Inhibit quitting so we can make a quit here
4603 : ;; look like a C-g typed as a command.
4604 : (inhibit-quit t))
4605 0 : (if (pos-visible-in-window-p mark (selected-window))
4606 : ;; Swap point-and-mark quickly so as to show the region that
4607 : ;; was selected. Don't do it if the region is highlighted.
4608 0 : (unless (and (region-active-p)
4609 0 : (face-background 'region))
4610 : ;; Swap point and mark.
4611 0 : (set-marker (mark-marker) (point) (current-buffer))
4612 0 : (goto-char mark)
4613 0 : (sit-for blink-matching-delay)
4614 : ;; Swap back.
4615 0 : (set-marker (mark-marker) mark (current-buffer))
4616 0 : (goto-char point)
4617 : ;; If user quit, deactivate the mark
4618 : ;; as C-g would as a command.
4619 0 : (and quit-flag (region-active-p)
4620 0 : (deactivate-mark)))
4621 0 : (let ((len (min (abs (- mark point))
4622 0 : (or message-len 40))))
4623 0 : (if (< point mark)
4624 : ;; Don't say "killed"; that is misleading.
4625 0 : (message "Saved text until \"%s\""
4626 0 : (buffer-substring-no-properties (- mark len) mark))
4627 0 : (message "Saved text from \"%s\""
4628 0 : (buffer-substring-no-properties mark (+ mark len))))))))
4629 :
4630 : (defun append-next-kill (&optional interactive)
4631 : "Cause following command, if it kills, to add to previous kill.
4632 : If the next command kills forward from point, the kill is
4633 : appended to the previous killed text. If the command kills
4634 : backward, the kill is prepended. Kill commands that act on the
4635 : region, such as `kill-region', are regarded as killing forward if
4636 : point is after mark, and killing backward if point is before
4637 : mark.
4638 :
4639 : If the next command is not a kill command, `append-next-kill' has
4640 : no effect.
4641 :
4642 : The argument is used for internal purposes; do not supply one."
4643 : (interactive "p")
4644 : ;; We don't use (interactive-p), since that breaks kbd macros.
4645 0 : (if interactive
4646 0 : (progn
4647 0 : (setq this-command 'kill-region)
4648 0 : (message "If the next command is a kill, it will append"))
4649 0 : (setq last-command 'kill-region)))
4650 :
4651 : (defvar bidi-directional-controls-chars "\x202a-\x202e\x2066-\x2069"
4652 : "Character set that matches bidirectional formatting control characters.")
4653 :
4654 : (defvar bidi-directional-non-controls-chars "^\x202a-\x202e\x2066-\x2069"
4655 : "Character set that matches any character except bidirectional controls.")
4656 :
4657 : (defun squeeze-bidi-context-1 (from to category replacement)
4658 : "A subroutine of `squeeze-bidi-context'.
4659 : FROM and TO should be markers, CATEGORY and REPLACEMENT should be strings."
4660 0 : (let ((pt (copy-marker from))
4661 0 : (limit (copy-marker to))
4662 : (old-pt 0)
4663 : lim1)
4664 0 : (setq lim1 limit)
4665 0 : (goto-char pt)
4666 0 : (while (< pt limit)
4667 0 : (if (> pt old-pt)
4668 0 : (move-marker lim1
4669 0 : (save-excursion
4670 : ;; L and R categories include embedding and
4671 : ;; override controls, but we don't want to
4672 : ;; replace them, because that might change
4673 : ;; the visual order. Likewise with PDF and
4674 : ;; isolate controls.
4675 0 : (+ pt (skip-chars-forward
4676 0 : bidi-directional-non-controls-chars
4677 0 : limit)))))
4678 : ;; Replace any run of non-RTL characters by a single LRM.
4679 0 : (if (null (re-search-forward category lim1 t))
4680 : ;; No more characters of CATEGORY, we are done.
4681 0 : (setq pt limit)
4682 0 : (replace-match replacement nil t)
4683 0 : (move-marker pt (point)))
4684 0 : (setq old-pt pt)
4685 : ;; Skip directional controls, if any.
4686 0 : (move-marker
4687 0 : pt (+ pt (skip-chars-forward bidi-directional-controls-chars limit))))))
4688 :
4689 : (defun squeeze-bidi-context (from to)
4690 : "Replace characters between FROM and TO while keeping bidi context.
4691 :
4692 : This function replaces the region of text with as few characters
4693 : as possible, while preserving the effect that region will have on
4694 : bidirectional display before and after the region."
4695 0 : (let ((start (set-marker (make-marker)
4696 0 : (if (> from 0) from (+ (point-max) from))))
4697 0 : (end (set-marker (make-marker) to))
4698 : ;; This is for when they copy text with read-only text
4699 : ;; properties.
4700 : (inhibit-read-only t))
4701 0 : (if (null (marker-position end))
4702 0 : (setq end (point-max-marker)))
4703 : ;; Replace each run of non-RTL characters with a single LRM.
4704 0 : (squeeze-bidi-context-1 start end "\\CR+" "\x200e")
4705 : ;; Replace each run of non-LTR characters with a single RLM. Note
4706 : ;; that the \cR category includes both the Arabic Letter (AL) and
4707 : ;; R characters; here we ignore the distinction between them,
4708 : ;; because that distinction only affects Arabic Number (AN)
4709 : ;; characters, which are weak and don't affect the reordering.
4710 0 : (squeeze-bidi-context-1 start end "\\CL+" "\x200f")))
4711 :
4712 : (defun line-substring-with-bidi-context (start end &optional no-properties)
4713 : "Return buffer text between START and END with its bidi context.
4714 :
4715 : START and END are assumed to belong to the same physical line
4716 : of buffer text. This function prepends and appends to the text
4717 : between START and END bidi control characters that preserve the
4718 : visual order of that text when it is inserted at some other place."
4719 0 : (if (or (< start (point-min))
4720 0 : (> end (point-max)))
4721 0 : (signal 'args-out-of-range (list (current-buffer) start end)))
4722 0 : (let ((buf (current-buffer))
4723 : substr para-dir from to)
4724 0 : (save-excursion
4725 0 : (goto-char start)
4726 0 : (setq para-dir (current-bidi-paragraph-direction))
4727 0 : (setq from (line-beginning-position)
4728 0 : to (line-end-position))
4729 0 : (goto-char from)
4730 : ;; If we don't have any mixed directional characters in the
4731 : ;; entire line, we can just copy the substring without adding
4732 : ;; any context.
4733 0 : (if (or (looking-at-p "\\CR*$")
4734 0 : (looking-at-p "\\CL*$"))
4735 0 : (setq substr (if no-properties
4736 0 : (buffer-substring-no-properties start end)
4737 0 : (buffer-substring start end)))
4738 0 : (setq substr
4739 0 : (with-temp-buffer
4740 0 : (if no-properties
4741 0 : (insert-buffer-substring-no-properties buf from to)
4742 0 : (insert-buffer-substring buf from to))
4743 0 : (squeeze-bidi-context 1 (1+ (- start from)))
4744 0 : (squeeze-bidi-context (- end to) nil)
4745 0 : (buffer-substring 1 (point-max)))))
4746 :
4747 : ;; Wrap the string in LRI/RLI..PDI pair to achieve 2 effects:
4748 : ;; (1) force the string to have the same base embedding
4749 : ;; direction as the paragraph direction at the source, no matter
4750 : ;; what is the paragraph direction at destination; and (2) avoid
4751 : ;; affecting the visual order of the surrounding text at
4752 : ;; destination if there are characters of different
4753 : ;; directionality there.
4754 0 : (concat (if (eq para-dir 'left-to-right) "\x2066" "\x2067")
4755 0 : substr "\x2069"))))
4756 :
4757 : (defun buffer-substring-with-bidi-context (start end &optional no-properties)
4758 : "Return portion of current buffer between START and END with bidi context.
4759 :
4760 : This function works similar to `buffer-substring', but it prepends and
4761 : appends to the text bidi directional control characters necessary to
4762 : preserve the visual appearance of the text if it is inserted at another
4763 : place. This is useful when the buffer substring includes bidirectional
4764 : text and control characters that cause non-trivial reordering on display.
4765 : If copied verbatim, such text can have a very different visual appearance,
4766 : and can also change the visual appearance of the surrounding text at the
4767 : destination of the copy.
4768 :
4769 : Optional argument NO-PROPERTIES, if non-nil, means copy the text without
4770 : the text properties."
4771 0 : (let (line-end substr)
4772 0 : (if (or (< start (point-min))
4773 0 : (> end (point-max)))
4774 0 : (signal 'args-out-of-range (list (current-buffer) start end)))
4775 0 : (save-excursion
4776 0 : (goto-char start)
4777 0 : (setq line-end (min end (line-end-position)))
4778 0 : (while (< start end)
4779 0 : (setq substr
4780 0 : (concat substr
4781 0 : (if substr "\n" "")
4782 0 : (line-substring-with-bidi-context start line-end
4783 0 : no-properties)))
4784 0 : (forward-line 1)
4785 0 : (setq start (point))
4786 0 : (setq line-end (min end (line-end-position))))
4787 0 : substr)))
4788 :
4789 : ;; Yanking.
4790 :
4791 : (defcustom yank-handled-properties
4792 : '((font-lock-face . yank-handle-font-lock-face-property)
4793 : (category . yank-handle-category-property))
4794 : "List of special text property handling conditions for yanking.
4795 : Each element should have the form (PROP . FUN), where PROP is a
4796 : property symbol and FUN is a function. When the `yank' command
4797 : inserts text into the buffer, it scans the inserted text for
4798 : stretches of text that have `eq' values of the text property
4799 : PROP; for each such stretch of text, FUN is called with three
4800 : arguments: the property's value in that text, and the start and
4801 : end positions of the text.
4802 :
4803 : This is done prior to removing the properties specified by
4804 : `yank-excluded-properties'."
4805 : :group 'killing
4806 : :type '(repeat (cons (symbol :tag "property symbol")
4807 : function))
4808 : :version "24.3")
4809 :
4810 : ;; This is actually used in subr.el but defcustom does not work there.
4811 : (defcustom yank-excluded-properties
4812 : '(category field follow-link fontified font-lock-face help-echo
4813 : intangible invisible keymap local-map mouse-face read-only
4814 : yank-handler)
4815 : "Text properties to discard when yanking.
4816 : The value should be a list of text properties to discard or t,
4817 : which means to discard all text properties.
4818 :
4819 : See also `yank-handled-properties'."
4820 : :type '(choice (const :tag "All" t) (repeat symbol))
4821 : :group 'killing
4822 : :version "24.3")
4823 :
4824 : (defvar yank-window-start nil)
4825 : (defvar yank-undo-function nil
4826 : "If non-nil, function used by `yank-pop' to delete last stretch of yanked text.
4827 : Function is called with two parameters, START and END corresponding to
4828 : the value of the mark and point; it is guaranteed that START <= END.
4829 : Normally set from the UNDO element of a yank-handler; see `insert-for-yank'.")
4830 :
4831 : (defun yank-pop (&optional arg)
4832 : "Replace just-yanked stretch of killed text with a different stretch.
4833 : This command is allowed only immediately after a `yank' or a `yank-pop'.
4834 : At such a time, the region contains a stretch of reinserted
4835 : previously-killed text. `yank-pop' deletes that text and inserts in its
4836 : place a different stretch of killed text.
4837 :
4838 : With no argument, the previous kill is inserted.
4839 : With argument N, insert the Nth previous kill.
4840 : If N is negative, this is a more recent kill.
4841 :
4842 : The sequence of kills wraps around, so that after the oldest one
4843 : comes the newest one.
4844 :
4845 : This command honors the `yank-handled-properties' and
4846 : `yank-excluded-properties' variables, and the `yank-handler' text
4847 : property, in the way that `yank' does."
4848 : (interactive "*p")
4849 0 : (if (not (eq last-command 'yank))
4850 0 : (user-error "Previous command was not a yank"))
4851 0 : (setq this-command 'yank)
4852 0 : (unless arg (setq arg 1))
4853 0 : (let ((inhibit-read-only t)
4854 0 : (before (< (point) (mark t))))
4855 0 : (if before
4856 0 : (funcall (or yank-undo-function 'delete-region) (point) (mark t))
4857 0 : (funcall (or yank-undo-function 'delete-region) (mark t) (point)))
4858 0 : (setq yank-undo-function nil)
4859 0 : (set-marker (mark-marker) (point) (current-buffer))
4860 0 : (insert-for-yank (current-kill arg))
4861 : ;; Set the window start back where it was in the yank command,
4862 : ;; if possible.
4863 0 : (set-window-start (selected-window) yank-window-start t)
4864 0 : (if before
4865 : ;; This is like exchange-point-and-mark, but doesn't activate the mark.
4866 : ;; It is cleaner to avoid activation, even though the command
4867 : ;; loop would deactivate the mark because we inserted text.
4868 0 : (goto-char (prog1 (mark t)
4869 0 : (set-marker (mark-marker) (point) (current-buffer))))))
4870 : nil)
4871 :
4872 : (defun yank (&optional arg)
4873 : "Reinsert (\"paste\") the last stretch of killed text.
4874 : More precisely, reinsert the most recent kill, which is the
4875 : stretch of killed text most recently killed OR yanked. Put point
4876 : at the end, and set mark at the beginning without activating it.
4877 : With just \\[universal-argument] as argument, put point at beginning, and mark at end.
4878 : With argument N, reinsert the Nth most recent kill.
4879 :
4880 : This command honors the `yank-handled-properties' and
4881 : `yank-excluded-properties' variables, and the `yank-handler' text
4882 : property, as described below.
4883 :
4884 : Properties listed in `yank-handled-properties' are processed,
4885 : then those listed in `yank-excluded-properties' are discarded.
4886 :
4887 : If STRING has a non-nil `yank-handler' property anywhere, the
4888 : normal insert behavior is altered, and instead, for each contiguous
4889 : segment of STRING that has a given value of the `yank-handler'
4890 : property, that value is used as follows:
4891 :
4892 : The value of a `yank-handler' property must be a list of one to four
4893 : elements, of the form (FUNCTION PARAM NOEXCLUDE UNDO).
4894 : FUNCTION, if non-nil, should be a function of one argument (the
4895 : object to insert); FUNCTION is called instead of `insert'.
4896 : PARAM, if present and non-nil, is passed to FUNCTION (to be handled
4897 : in whatever way is appropriate; e.g. if FUNCTION is `yank-rectangle',
4898 : PARAM may be a list of strings to insert as a rectangle). If PARAM
4899 : is nil, then the current segment of STRING is used.
4900 : If NOEXCLUDE is present and non-nil, the normal removal of
4901 : `yank-excluded-properties' is not performed; instead FUNCTION is
4902 : responsible for the removal. This may be necessary if FUNCTION
4903 : adjusts point before or after inserting the object.
4904 : UNDO, if present and non-nil, should be a function to be called
4905 : by `yank-pop' to undo the insertion of the current PARAM. It is
4906 : given two arguments, the start and end of the region. FUNCTION
4907 : may set `yank-undo-function' to override UNDO.
4908 :
4909 : See also the command `yank-pop' (\\[yank-pop])."
4910 : (interactive "*P")
4911 0 : (setq yank-window-start (window-start))
4912 : ;; If we don't get all the way thru, make last-command indicate that
4913 : ;; for the following command.
4914 0 : (setq this-command t)
4915 0 : (push-mark)
4916 0 : (insert-for-yank (current-kill (cond
4917 0 : ((listp arg) 0)
4918 0 : ((eq arg '-) -2)
4919 0 : (t (1- arg)))))
4920 0 : (if (consp arg)
4921 : ;; This is like exchange-point-and-mark, but doesn't activate the mark.
4922 : ;; It is cleaner to avoid activation, even though the command
4923 : ;; loop would deactivate the mark because we inserted text.
4924 0 : (goto-char (prog1 (mark t)
4925 0 : (set-marker (mark-marker) (point) (current-buffer)))))
4926 : ;; If we do get all the way thru, make this-command indicate that.
4927 0 : (if (eq this-command t)
4928 0 : (setq this-command 'yank))
4929 : nil)
4930 :
4931 : (defun rotate-yank-pointer (arg)
4932 : "Rotate the yanking point in the kill ring.
4933 : With ARG, rotate that many kills forward (or backward, if negative)."
4934 : (interactive "p")
4935 0 : (current-kill arg))
4936 :
4937 : ;; Some kill commands.
4938 :
4939 : ;; Internal subroutine of delete-char
4940 : (defun kill-forward-chars (arg)
4941 0 : (if (listp arg) (setq arg (car arg)))
4942 0 : (if (eq arg '-) (setq arg -1))
4943 0 : (kill-region (point) (+ (point) arg)))
4944 :
4945 : ;; Internal subroutine of backward-delete-char
4946 : (defun kill-backward-chars (arg)
4947 0 : (if (listp arg) (setq arg (car arg)))
4948 0 : (if (eq arg '-) (setq arg -1))
4949 0 : (kill-region (point) (- (point) arg)))
4950 :
4951 : (defcustom backward-delete-char-untabify-method 'untabify
4952 : "The method for untabifying when deleting backward.
4953 : Can be `untabify' -- turn a tab to many spaces, then delete one space;
4954 : `hungry' -- delete all whitespace, both tabs and spaces;
4955 : `all' -- delete all whitespace, including tabs, spaces and newlines;
4956 : nil -- just delete one character."
4957 : :type '(choice (const untabify) (const hungry) (const all) (const nil))
4958 : :version "20.3"
4959 : :group 'killing)
4960 :
4961 : (defun backward-delete-char-untabify (arg &optional killp)
4962 : "Delete characters backward, changing tabs into spaces.
4963 : The exact behavior depends on `backward-delete-char-untabify-method'.
4964 : Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
4965 : Interactively, ARG is the prefix arg (default 1)
4966 : and KILLP is t if a prefix arg was specified."
4967 : (interactive "*p\nP")
4968 0 : (when (eq backward-delete-char-untabify-method 'untabify)
4969 0 : (let ((count arg))
4970 0 : (save-excursion
4971 0 : (while (and (> count 0) (not (bobp)))
4972 0 : (if (= (preceding-char) ?\t)
4973 0 : (let ((col (current-column)))
4974 0 : (forward-char -1)
4975 0 : (setq col (- col (current-column)))
4976 0 : (insert-char ?\s col)
4977 0 : (delete-char 1)))
4978 0 : (forward-char -1)
4979 0 : (setq count (1- count))))))
4980 0 : (let* ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t")
4981 0 : ((eq backward-delete-char-untabify-method 'all)
4982 0 : " \t\n\r")))
4983 0 : (n (if skip
4984 0 : (let* ((oldpt (point))
4985 0 : (wh (- oldpt (save-excursion
4986 0 : (skip-chars-backward skip)
4987 0 : (constrain-to-field nil oldpt)))))
4988 0 : (+ arg (if (zerop wh) 0 (1- wh))))
4989 0 : arg)))
4990 : ;; Avoid warning about delete-backward-char
4991 0 : (with-no-warnings (delete-backward-char n killp))))
4992 :
4993 : (defun zap-to-char (arg char)
4994 : "Kill up to and including ARGth occurrence of CHAR.
4995 : Case is ignored if `case-fold-search' is non-nil in the current buffer.
4996 : Goes backward if ARG is negative; error if CHAR not found."
4997 0 : (interactive (list (prefix-numeric-value current-prefix-arg)
4998 0 : (read-char "Zap to char: " t)))
4999 : ;; Avoid "obsolete" warnings for translation-table-for-input.
5000 0 : (with-no-warnings
5001 0 : (if (char-table-p translation-table-for-input)
5002 0 : (setq char (or (aref translation-table-for-input char) char))))
5003 0 : (kill-region (point) (progn
5004 0 : (search-forward (char-to-string char) nil nil arg)
5005 0 : (point))))
5006 :
5007 : ;; kill-line and its subroutines.
5008 :
5009 : (defcustom kill-whole-line nil
5010 : "If non-nil, `kill-line' with no arg at start of line kills the whole line."
5011 : :type 'boolean
5012 : :group 'killing)
5013 :
5014 : (defun kill-line (&optional arg)
5015 : "Kill the rest of the current line; if no nonblanks there, kill thru newline.
5016 : With prefix argument ARG, kill that many lines from point.
5017 : Negative arguments kill lines backward.
5018 : With zero argument, kills the text before point on the current line.
5019 :
5020 : When calling from a program, nil means \"no arg\",
5021 : a number counts as a prefix arg.
5022 :
5023 : To kill a whole line, when point is not at the beginning, type \
5024 : \\[move-beginning-of-line] \\[kill-line] \\[kill-line].
5025 :
5026 : If `show-trailing-whitespace' is non-nil, this command will just
5027 : kill the rest of the current line, even if there are no nonblanks
5028 : there.
5029 :
5030 : If option `kill-whole-line' is non-nil, then this command kills the whole line
5031 : including its terminating newline, when used at the beginning of a line
5032 : with no argument. As a consequence, you can always kill a whole line
5033 : by typing \\[move-beginning-of-line] \\[kill-line].
5034 :
5035 : If you want to append the killed line to the last killed text,
5036 : use \\[append-next-kill] before \\[kill-line].
5037 :
5038 : If the buffer is read-only, Emacs will beep and refrain from deleting
5039 : the line, but put the line in the kill ring anyway. This means that
5040 : you can use this command to copy text from a read-only buffer.
5041 : \(If the variable `kill-read-only-ok' is non-nil, then this won't
5042 : even beep.)"
5043 : (interactive "P")
5044 0 : (kill-region (point)
5045 : ;; It is better to move point to the other end of the kill
5046 : ;; before killing. That way, in a read-only buffer, point
5047 : ;; moves across the text that is copied to the kill ring.
5048 : ;; The choice has no effect on undo now that undo records
5049 : ;; the value of point from before the command was run.
5050 0 : (progn
5051 0 : (if arg
5052 0 : (forward-visible-line (prefix-numeric-value arg))
5053 0 : (if (eobp)
5054 0 : (signal 'end-of-buffer nil))
5055 0 : (let ((end
5056 0 : (save-excursion
5057 0 : (end-of-visible-line) (point))))
5058 0 : (if (or (save-excursion
5059 : ;; If trailing whitespace is visible,
5060 : ;; don't treat it as nothing.
5061 0 : (unless show-trailing-whitespace
5062 0 : (skip-chars-forward " \t" end))
5063 0 : (= (point) end))
5064 0 : (and kill-whole-line (bolp)))
5065 0 : (forward-visible-line 1)
5066 0 : (goto-char end))))
5067 0 : (point))))
5068 :
5069 : (defun kill-whole-line (&optional arg)
5070 : "Kill current line.
5071 : With prefix ARG, kill that many lines starting from the current line.
5072 : If ARG is negative, kill backward. Also kill the preceding newline.
5073 : \(This is meant to make \\[repeat] work well with negative arguments.)
5074 : If ARG is zero, kill current line but exclude the trailing newline."
5075 : (interactive "p")
5076 0 : (or arg (setq arg 1))
5077 0 : (if (and (> arg 0) (eobp) (save-excursion (forward-visible-line 0) (eobp)))
5078 0 : (signal 'end-of-buffer nil))
5079 0 : (if (and (< arg 0) (bobp) (save-excursion (end-of-visible-line) (bobp)))
5080 0 : (signal 'beginning-of-buffer nil))
5081 0 : (unless (eq last-command 'kill-region)
5082 0 : (kill-new "")
5083 0 : (setq last-command 'kill-region))
5084 0 : (cond ((zerop arg)
5085 : ;; We need to kill in two steps, because the previous command
5086 : ;; could have been a kill command, in which case the text
5087 : ;; before point needs to be prepended to the current kill
5088 : ;; ring entry and the text after point appended. Also, we
5089 : ;; need to use save-excursion to avoid copying the same text
5090 : ;; twice to the kill ring in read-only buffers.
5091 0 : (save-excursion
5092 0 : (kill-region (point) (progn (forward-visible-line 0) (point))))
5093 0 : (kill-region (point) (progn (end-of-visible-line) (point))))
5094 0 : ((< arg 0)
5095 0 : (save-excursion
5096 0 : (kill-region (point) (progn (end-of-visible-line) (point))))
5097 0 : (kill-region (point)
5098 0 : (progn (forward-visible-line (1+ arg))
5099 0 : (unless (bobp) (backward-char))
5100 0 : (point))))
5101 : (t
5102 0 : (save-excursion
5103 0 : (kill-region (point) (progn (forward-visible-line 0) (point))))
5104 0 : (kill-region (point)
5105 0 : (progn (forward-visible-line arg) (point))))))
5106 :
5107 : (defun forward-visible-line (arg)
5108 : "Move forward by ARG lines, ignoring currently invisible newlines only.
5109 : If ARG is negative, move backward -ARG lines.
5110 : If ARG is zero, move to the beginning of the current line."
5111 0 : (condition-case nil
5112 0 : (if (> arg 0)
5113 0 : (progn
5114 0 : (while (> arg 0)
5115 0 : (or (zerop (forward-line 1))
5116 0 : (signal 'end-of-buffer nil))
5117 : ;; If the newline we just skipped is invisible,
5118 : ;; don't count it.
5119 0 : (let ((prop
5120 0 : (get-char-property (1- (point)) 'invisible)))
5121 0 : (if (if (eq buffer-invisibility-spec t)
5122 0 : prop
5123 0 : (or (memq prop buffer-invisibility-spec)
5124 0 : (assq prop buffer-invisibility-spec)))
5125 0 : (setq arg (1+ arg))))
5126 0 : (setq arg (1- arg)))
5127 : ;; If invisible text follows, and it is a number of complete lines,
5128 : ;; skip it.
5129 0 : (let ((opoint (point)))
5130 0 : (while (and (not (eobp))
5131 0 : (let ((prop
5132 0 : (get-char-property (point) 'invisible)))
5133 0 : (if (eq buffer-invisibility-spec t)
5134 0 : prop
5135 0 : (or (memq prop buffer-invisibility-spec)
5136 0 : (assq prop buffer-invisibility-spec)))))
5137 0 : (goto-char
5138 0 : (if (get-text-property (point) 'invisible)
5139 0 : (or (next-single-property-change (point) 'invisible)
5140 0 : (point-max))
5141 0 : (next-overlay-change (point)))))
5142 0 : (unless (bolp)
5143 0 : (goto-char opoint))))
5144 0 : (let ((first t))
5145 0 : (while (or first (<= arg 0))
5146 0 : (if first
5147 0 : (beginning-of-line)
5148 0 : (or (zerop (forward-line -1))
5149 0 : (signal 'beginning-of-buffer nil)))
5150 : ;; If the newline we just moved to is invisible,
5151 : ;; don't count it.
5152 0 : (unless (bobp)
5153 0 : (let ((prop
5154 0 : (get-char-property (1- (point)) 'invisible)))
5155 0 : (unless (if (eq buffer-invisibility-spec t)
5156 0 : prop
5157 0 : (or (memq prop buffer-invisibility-spec)
5158 0 : (assq prop buffer-invisibility-spec)))
5159 0 : (setq arg (1+ arg)))))
5160 0 : (setq first nil))
5161 : ;; If invisible text follows, and it is a number of complete lines,
5162 : ;; skip it.
5163 0 : (let ((opoint (point)))
5164 0 : (while (and (not (bobp))
5165 0 : (let ((prop
5166 0 : (get-char-property (1- (point)) 'invisible)))
5167 0 : (if (eq buffer-invisibility-spec t)
5168 0 : prop
5169 0 : (or (memq prop buffer-invisibility-spec)
5170 0 : (assq prop buffer-invisibility-spec)))))
5171 0 : (goto-char
5172 0 : (if (get-text-property (1- (point)) 'invisible)
5173 0 : (or (previous-single-property-change (point) 'invisible)
5174 0 : (point-min))
5175 0 : (previous-overlay-change (point)))))
5176 0 : (unless (bolp)
5177 0 : (goto-char opoint)))))
5178 : ((beginning-of-buffer end-of-buffer)
5179 0 : nil)))
5180 :
5181 : (defun end-of-visible-line ()
5182 : "Move to end of current visible line."
5183 0 : (end-of-line)
5184 : ;; If the following character is currently invisible,
5185 : ;; skip all characters with that same `invisible' property value,
5186 : ;; then find the next newline.
5187 0 : (while (and (not (eobp))
5188 0 : (save-excursion
5189 0 : (skip-chars-forward "^\n")
5190 0 : (let ((prop
5191 0 : (get-char-property (point) 'invisible)))
5192 0 : (if (eq buffer-invisibility-spec t)
5193 0 : prop
5194 0 : (or (memq prop buffer-invisibility-spec)
5195 0 : (assq prop buffer-invisibility-spec))))))
5196 0 : (skip-chars-forward "^\n")
5197 0 : (if (get-text-property (point) 'invisible)
5198 0 : (goto-char (or (next-single-property-change (point) 'invisible)
5199 0 : (point-max)))
5200 0 : (goto-char (next-overlay-change (point))))
5201 0 : (end-of-line)))
5202 :
5203 : (defun kill-current-buffer ()
5204 : "Kill the current buffer.
5205 : When called in the minibuffer, get out of the minibuffer
5206 : using `abort-recursive-edit'.
5207 :
5208 : This is like `kill-this-buffer', but it doesn't have to be invoked
5209 : via the menu bar, and pays no attention to the menu-bar's frame."
5210 : (interactive)
5211 0 : (let ((frame (selected-frame)))
5212 0 : (if (and (frame-live-p frame)
5213 0 : (not (window-minibuffer-p (frame-selected-window frame))))
5214 0 : (kill-buffer (current-buffer))
5215 0 : (abort-recursive-edit))))
5216 :
5217 :
5218 : (defun insert-buffer (buffer)
5219 : "Insert after point the contents of BUFFER.
5220 : Puts mark after the inserted text.
5221 : BUFFER may be a buffer or a buffer name."
5222 : (declare (interactive-only insert-buffer-substring))
5223 : (interactive
5224 0 : (list
5225 0 : (progn
5226 0 : (barf-if-buffer-read-only)
5227 0 : (read-buffer "Insert buffer: "
5228 0 : (if (eq (selected-window) (next-window))
5229 0 : (other-buffer (current-buffer))
5230 0 : (window-buffer (next-window)))
5231 0 : t))))
5232 0 : (push-mark
5233 0 : (save-excursion
5234 0 : (insert-buffer-substring (get-buffer buffer))
5235 0 : (point)))
5236 : nil)
5237 :
5238 : (defun append-to-buffer (buffer start end)
5239 : "Append to specified buffer the text of the region.
5240 : It is inserted into that buffer before its point.
5241 :
5242 : When calling from a program, give three arguments:
5243 : BUFFER (or buffer name), START and END.
5244 : START and END specify the portion of the current buffer to be copied."
5245 : (interactive
5246 0 : (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) t))
5247 0 : (region-beginning) (region-end)))
5248 0 : (let* ((oldbuf (current-buffer))
5249 0 : (append-to (get-buffer-create buffer))
5250 0 : (windows (get-buffer-window-list append-to t t))
5251 : point)
5252 0 : (save-excursion
5253 0 : (with-current-buffer append-to
5254 0 : (setq point (point))
5255 0 : (barf-if-buffer-read-only)
5256 0 : (insert-buffer-substring oldbuf start end)
5257 0 : (dolist (window windows)
5258 0 : (when (= (window-point window) point)
5259 0 : (set-window-point window (point))))))))
5260 :
5261 : (defun prepend-to-buffer (buffer start end)
5262 : "Prepend to specified buffer the text of the region.
5263 : It is inserted into that buffer after its point.
5264 :
5265 : When calling from a program, give three arguments:
5266 : BUFFER (or buffer name), START and END.
5267 : START and END specify the portion of the current buffer to be copied."
5268 : (interactive "BPrepend to buffer: \nr")
5269 0 : (let ((oldbuf (current-buffer)))
5270 0 : (with-current-buffer (get-buffer-create buffer)
5271 0 : (barf-if-buffer-read-only)
5272 0 : (save-excursion
5273 0 : (insert-buffer-substring oldbuf start end)))))
5274 :
5275 : (defun copy-to-buffer (buffer start end)
5276 : "Copy to specified buffer the text of the region.
5277 : It is inserted into that buffer, replacing existing text there.
5278 :
5279 : When calling from a program, give three arguments:
5280 : BUFFER (or buffer name), START and END.
5281 : START and END specify the portion of the current buffer to be copied."
5282 : (interactive "BCopy to buffer: \nr")
5283 0 : (let ((oldbuf (current-buffer)))
5284 0 : (with-current-buffer (get-buffer-create buffer)
5285 0 : (barf-if-buffer-read-only)
5286 0 : (erase-buffer)
5287 0 : (save-excursion
5288 0 : (insert-buffer-substring oldbuf start end)))))
5289 :
5290 : (define-error 'mark-inactive (purecopy "The mark is not active now"))
5291 :
5292 : (defvar activate-mark-hook nil
5293 : "Hook run when the mark becomes active.
5294 : It is also run at the end of a command, if the mark is active and
5295 : it is possible that the region may have changed.")
5296 :
5297 : (defvar deactivate-mark-hook nil
5298 : "Hook run when the mark becomes inactive.")
5299 :
5300 : (defun mark (&optional force)
5301 : "Return this buffer's mark value as integer, or nil if never set.
5302 :
5303 : In Transient Mark mode, this function signals an error if
5304 : the mark is not active. However, if `mark-even-if-inactive' is non-nil,
5305 : or the argument FORCE is non-nil, it disregards whether the mark
5306 : is active, and returns an integer or nil in the usual way.
5307 :
5308 : If you are using this in an editing command, you are most likely making
5309 : a mistake; see the documentation of `set-mark'."
5310 8 : (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive)
5311 8 : (marker-position (mark-marker))
5312 8 : (signal 'mark-inactive nil)))
5313 :
5314 : ;; Behind display-selections-p.
5315 :
5316 : (defun deactivate-mark (&optional force)
5317 : "Deactivate the mark.
5318 : If Transient Mark mode is disabled, this function normally does
5319 : nothing; but if FORCE is non-nil, it deactivates the mark anyway.
5320 :
5321 : Deactivating the mark sets `mark-active' to nil, updates the
5322 : primary selection according to `select-active-regions', and runs
5323 : `deactivate-mark-hook'.
5324 :
5325 : If Transient Mark mode was temporarily enabled, reset the value
5326 : of the variable `transient-mark-mode'; if this causes Transient
5327 : Mark mode to be disabled, don't change `mark-active' to nil or
5328 : run `deactivate-mark-hook'."
5329 0 : (when (or (region-active-p) force)
5330 0 : (when (and (if (eq select-active-regions 'only)
5331 0 : (eq (car-safe transient-mark-mode) 'only)
5332 0 : select-active-regions)
5333 0 : (region-active-p)
5334 0 : (display-selections-p))
5335 : ;; The var `saved-region-selection', if non-nil, is the text in
5336 : ;; the region prior to the last command modifying the buffer.
5337 : ;; Set the selection to that, or to the current region.
5338 0 : (cond (saved-region-selection
5339 0 : (if (gui-backend-selection-owner-p 'PRIMARY)
5340 0 : (gui-set-selection 'PRIMARY saved-region-selection))
5341 0 : (setq saved-region-selection nil))
5342 : ;; If another program has acquired the selection, region
5343 : ;; deactivation should not clobber it (Bug#11772).
5344 0 : ((and (/= (region-beginning) (region-end))
5345 0 : (or (gui-backend-selection-owner-p 'PRIMARY)
5346 0 : (null (gui-backend-selection-exists-p 'PRIMARY))))
5347 0 : (gui-set-selection 'PRIMARY
5348 0 : (funcall region-extract-function nil)))))
5349 0 : (when mark-active (force-mode-line-update)) ;Refresh toolbar (bug#16382).
5350 0 : (cond
5351 0 : ((eq (car-safe transient-mark-mode) 'only)
5352 0 : (setq transient-mark-mode (cdr transient-mark-mode))
5353 0 : (if (eq transient-mark-mode (default-value 'transient-mark-mode))
5354 0 : (kill-local-variable 'transient-mark-mode)))
5355 0 : ((eq transient-mark-mode 'lambda)
5356 0 : (kill-local-variable 'transient-mark-mode)))
5357 0 : (setq mark-active nil)
5358 0 : (run-hooks 'deactivate-mark-hook)
5359 0 : (redisplay--update-region-highlight (selected-window))))
5360 :
5361 : (defun activate-mark (&optional no-tmm)
5362 : "Activate the mark.
5363 : If NO-TMM is non-nil, leave `transient-mark-mode' alone."
5364 2 : (when (mark t)
5365 2 : (unless (region-active-p)
5366 2 : (force-mode-line-update) ;Refresh toolbar (bug#16382).
5367 2 : (setq mark-active t)
5368 2 : (unless (or transient-mark-mode no-tmm)
5369 2 : (setq-local transient-mark-mode 'lambda))
5370 2 : (run-hooks 'activate-mark-hook))))
5371 :
5372 : (defun set-mark (pos)
5373 : "Set this buffer's mark to POS. Don't use this function!
5374 : That is to say, don't use this function unless you want
5375 : the user to see that the mark has moved, and you want the previous
5376 : mark position to be lost.
5377 :
5378 : Normally, when a new mark is set, the old one should go on the stack.
5379 : This is why most applications should use `push-mark', not `set-mark'.
5380 :
5381 : Novice Emacs Lisp programmers often try to use the mark for the wrong
5382 : purposes. The mark saves a location for the user's convenience.
5383 : Most editing commands should not alter the mark.
5384 : To remember a location for internal use in the Lisp program,
5385 : store it in a Lisp variable. Example:
5386 :
5387 : (let ((beg (point))) (forward-line 1) (delete-region beg (point)))."
5388 2 : (if pos
5389 2 : (progn
5390 2 : (set-marker (mark-marker) pos (current-buffer))
5391 2 : (activate-mark 'no-tmm))
5392 : ;; Normally we never clear mark-active except in Transient Mark mode.
5393 : ;; But when we actually clear out the mark value too, we must
5394 : ;; clear mark-active in any mode.
5395 0 : (deactivate-mark t)
5396 : ;; `deactivate-mark' sometimes leaves mark-active non-nil, but
5397 : ;; it should never be nil if the mark is nil.
5398 0 : (setq mark-active nil)
5399 2 : (set-marker (mark-marker) nil)))
5400 :
5401 : (defun save-mark-and-excursion--save ()
5402 0 : (cons
5403 0 : (let ((mark (mark-marker)))
5404 0 : (and (marker-position mark) (copy-marker mark)))
5405 0 : mark-active))
5406 :
5407 : (defun save-mark-and-excursion--restore (saved-mark-info)
5408 0 : (let ((saved-mark (car saved-mark-info))
5409 0 : (omark (marker-position (mark-marker)))
5410 : (nmark nil)
5411 0 : (saved-mark-active (cdr saved-mark-info)))
5412 : ;; Mark marker
5413 0 : (if (null saved-mark)
5414 0 : (set-marker (mark-marker) nil)
5415 0 : (setf nmark (marker-position saved-mark))
5416 0 : (set-marker (mark-marker) nmark)
5417 0 : (set-marker saved-mark nil))
5418 : ;; Mark active
5419 0 : (let ((cur-mark-active mark-active))
5420 0 : (setq mark-active saved-mark-active)
5421 : ;; If mark is active now, and either was not active or was at a
5422 : ;; different place, run the activate hook.
5423 0 : (if saved-mark-active
5424 0 : (when (or (not cur-mark-active)
5425 0 : (not (eq omark nmark)))
5426 0 : (run-hooks 'activate-mark-hook))
5427 : ;; If mark has ceased to be active, run deactivate hook.
5428 0 : (when cur-mark-active
5429 0 : (run-hooks 'deactivate-mark-hook))))))
5430 :
5431 : (defmacro save-mark-and-excursion (&rest body)
5432 : "Like `save-excursion', but also save and restore the mark state.
5433 : This macro does what `save-excursion' did before Emacs 25.1."
5434 : (declare (indent 0) (debug t))
5435 1 : (let ((saved-marker-sym (make-symbol "saved-marker")))
5436 1 : `(let ((,saved-marker-sym (save-mark-and-excursion--save)))
5437 : (unwind-protect
5438 1 : (save-excursion ,@body)
5439 1 : (save-mark-and-excursion--restore ,saved-marker-sym)))))
5440 :
5441 : (defcustom use-empty-active-region nil
5442 : "Whether \"region-aware\" commands should act on empty regions.
5443 : If nil, region-aware commands treat the empty region as inactive.
5444 : If non-nil, region-aware commands treat the region as active as
5445 : long as the mark is active, even if the region is empty.
5446 :
5447 : Region-aware commands are those that act on the region if it is
5448 : active and Transient Mark mode is enabled, and on the text near
5449 : point otherwise."
5450 : :type 'boolean
5451 : :version "23.1"
5452 : :group 'editing-basics)
5453 :
5454 : (defun use-region-p ()
5455 : "Return t if the region is active and it is appropriate to act on it.
5456 : This is used by commands that act specially on the region under
5457 : Transient Mark mode.
5458 :
5459 : The return value is t if Transient Mark mode is enabled and the
5460 : mark is active; furthermore, if `use-empty-active-region' is nil,
5461 : the region must not be empty. Otherwise, the return value is nil.
5462 :
5463 : For some commands, it may be appropriate to ignore the value of
5464 : `use-empty-active-region'; in that case, use `region-active-p'."
5465 0 : (and (region-active-p)
5466 0 : (or use-empty-active-region (> (region-end) (region-beginning)))))
5467 :
5468 : (defun region-active-p ()
5469 : "Return non-nil if Transient Mark mode is enabled and the mark is active.
5470 :
5471 : Some commands act specially on the region when Transient Mark
5472 : mode is enabled. Usually, such commands should use
5473 : `use-region-p' instead of this function, because `use-region-p'
5474 : also checks the value of `use-empty-active-region'."
5475 2 : (and transient-mark-mode mark-active
5476 : ;; FIXME: Somehow we sometimes end up with mark-active non-nil but
5477 : ;; without the mark being set (e.g. bug#17324). We really should fix
5478 : ;; that problem, but in the mean time, let's make sure we don't say the
5479 : ;; region is active when there's no mark.
5480 2 : (progn (cl-assert (mark)) t)))
5481 :
5482 : (defun region-bounds ()
5483 : "Return the boundaries of the region as a list of (START . END) positions."
5484 0 : (funcall region-extract-function 'bounds))
5485 :
5486 : (defun region-noncontiguous-p ()
5487 : "Return non-nil if the region contains several pieces.
5488 : An example is a rectangular region handled as a list of
5489 : separate contiguous regions for each line."
5490 0 : (> (length (region-bounds)) 1))
5491 :
5492 : (defvar redisplay-unhighlight-region-function
5493 : (lambda (rol) (when (overlayp rol) (delete-overlay rol))))
5494 :
5495 : (defvar redisplay-highlight-region-function
5496 : (lambda (start end window rol)
5497 : (if (not (overlayp rol))
5498 : (let ((nrol (make-overlay start end)))
5499 : (funcall redisplay-unhighlight-region-function rol)
5500 : (overlay-put nrol 'window window)
5501 : (overlay-put nrol 'face 'region)
5502 : ;; Normal priority so that a large region doesn't hide all the
5503 : ;; overlays within it, but high secondary priority so that if it
5504 : ;; ends/starts in the middle of a small overlay, that small overlay
5505 : ;; won't hide the region's boundaries.
5506 : (overlay-put nrol 'priority '(nil . 100))
5507 : nrol)
5508 : (unless (and (eq (overlay-buffer rol) (current-buffer))
5509 : (eq (overlay-start rol) start)
5510 : (eq (overlay-end rol) end))
5511 : (move-overlay rol start end (current-buffer)))
5512 : rol)))
5513 :
5514 : (defun redisplay--update-region-highlight (window)
5515 0 : (let ((rol (window-parameter window 'internal-region-overlay)))
5516 0 : (if (not (and (region-active-p)
5517 0 : (or highlight-nonselected-windows
5518 0 : (eq window (selected-window))
5519 0 : (and (window-minibuffer-p)
5520 0 : (eq window (minibuffer-selected-window))))))
5521 0 : (funcall redisplay-unhighlight-region-function rol)
5522 0 : (let* ((pt (window-point window))
5523 0 : (mark (mark))
5524 0 : (start (min pt mark))
5525 0 : (end (max pt mark))
5526 : (new
5527 0 : (funcall redisplay-highlight-region-function
5528 0 : start end window rol)))
5529 0 : (unless (equal new rol)
5530 0 : (set-window-parameter window 'internal-region-overlay
5531 0 : new))))))
5532 :
5533 : (defvar pre-redisplay-functions (list #'redisplay--update-region-highlight)
5534 : "Hook run just before redisplay.
5535 : It is called in each window that is to be redisplayed. It takes one argument,
5536 : which is the window that will be redisplayed. When run, the `current-buffer'
5537 : is set to the buffer displayed in that window.")
5538 :
5539 : (defun redisplay--pre-redisplay-functions (windows)
5540 0 : (with-demoted-errors "redisplay--pre-redisplay-functions: %S"
5541 0 : (if (null windows)
5542 0 : (with-current-buffer (window-buffer (selected-window))
5543 0 : (run-hook-with-args 'pre-redisplay-functions (selected-window)))
5544 0 : (dolist (win (if (listp windows) windows (window-list-1 nil nil t)))
5545 0 : (with-current-buffer (window-buffer win)
5546 0 : (run-hook-with-args 'pre-redisplay-functions win))))))
5547 :
5548 : (add-function :before pre-redisplay-function
5549 : #'redisplay--pre-redisplay-functions)
5550 :
5551 :
5552 : (defvar-local mark-ring nil
5553 : "The list of former marks of the current buffer, most recent first.")
5554 : (put 'mark-ring 'permanent-local t)
5555 :
5556 : (defcustom mark-ring-max 16
5557 : "Maximum size of mark ring. Start discarding off end if gets this big."
5558 : :type 'integer
5559 : :group 'editing-basics)
5560 :
5561 : (defvar global-mark-ring nil
5562 : "The list of saved global marks, most recent first.")
5563 :
5564 : (defcustom global-mark-ring-max 16
5565 : "Maximum size of global mark ring. \
5566 : Start discarding off end if gets this big."
5567 : :type 'integer
5568 : :group 'editing-basics)
5569 :
5570 : (defun pop-to-mark-command ()
5571 : "Jump to mark, and pop a new position for mark off the ring.
5572 : \(Does not affect global mark ring)."
5573 : (interactive)
5574 0 : (if (null (mark t))
5575 0 : (user-error "No mark set in this buffer")
5576 0 : (if (= (point) (mark t))
5577 0 : (message "Mark popped"))
5578 0 : (goto-char (mark t))
5579 0 : (pop-mark)))
5580 :
5581 : (defun push-mark-command (arg &optional nomsg)
5582 : "Set mark at where point is.
5583 : If no prefix ARG and mark is already set there, just activate it.
5584 : Display `Mark set' unless the optional second arg NOMSG is non-nil."
5585 : (interactive "P")
5586 0 : (let ((mark (mark t)))
5587 0 : (if (or arg (null mark) (/= mark (point)))
5588 0 : (push-mark nil nomsg t)
5589 0 : (activate-mark 'no-tmm)
5590 0 : (unless nomsg
5591 0 : (message "Mark activated")))))
5592 :
5593 : (defcustom set-mark-command-repeat-pop nil
5594 : "Non-nil means repeating \\[set-mark-command] after popping mark pops it again.
5595 : That means that C-u \\[set-mark-command] \\[set-mark-command]
5596 : will pop the mark twice, and
5597 : C-u \\[set-mark-command] \\[set-mark-command] \\[set-mark-command]
5598 : will pop the mark three times.
5599 :
5600 : A value of nil means \\[set-mark-command]'s behavior does not change
5601 : after C-u \\[set-mark-command]."
5602 : :type 'boolean
5603 : :group 'editing-basics)
5604 :
5605 : (defun set-mark-command (arg)
5606 : "Set the mark where point is, and activate it; or jump to the mark.
5607 : Setting the mark also alters the region, which is the text
5608 : between point and mark; this is the closest equivalent in
5609 : Emacs to what some editors call the \"selection\".
5610 :
5611 : With no prefix argument, set the mark at point, and push the
5612 : old mark position on local mark ring. Also push the new mark on
5613 : global mark ring, if the previous mark was set in another buffer.
5614 :
5615 : When Transient Mark Mode is off, immediately repeating this
5616 : command activates `transient-mark-mode' temporarily.
5617 :
5618 : With prefix argument (e.g., \\[universal-argument] \\[set-mark-command]), \
5619 : jump to the mark, and set the mark from
5620 : position popped off the local mark ring (this does not affect the global
5621 : mark ring). Use \\[pop-global-mark] to jump to a mark popped off the global
5622 : mark ring (see `pop-global-mark').
5623 :
5624 : If `set-mark-command-repeat-pop' is non-nil, repeating
5625 : the \\[set-mark-command] command with no prefix argument pops the next position
5626 : off the local (or global) mark ring and jumps there.
5627 :
5628 : With \\[universal-argument] \\[universal-argument] as prefix
5629 : argument, unconditionally set mark where point is, even if
5630 : `set-mark-command-repeat-pop' is non-nil.
5631 :
5632 : Novice Emacs Lisp programmers often try to use the mark for the wrong
5633 : purposes. See the documentation of `set-mark' for more information."
5634 : (interactive "P")
5635 0 : (cond ((eq transient-mark-mode 'lambda)
5636 0 : (kill-local-variable 'transient-mark-mode))
5637 0 : ((eq (car-safe transient-mark-mode) 'only)
5638 0 : (deactivate-mark)))
5639 0 : (cond
5640 0 : ((and (consp arg) (> (prefix-numeric-value arg) 4))
5641 0 : (push-mark-command nil))
5642 0 : ((not (eq this-command 'set-mark-command))
5643 0 : (if arg
5644 0 : (pop-to-mark-command)
5645 0 : (push-mark-command t)))
5646 0 : ((and set-mark-command-repeat-pop
5647 0 : (eq last-command 'pop-global-mark)
5648 0 : (not arg))
5649 0 : (setq this-command 'pop-global-mark)
5650 0 : (pop-global-mark))
5651 0 : ((or (and set-mark-command-repeat-pop
5652 0 : (eq last-command 'pop-to-mark-command))
5653 0 : arg)
5654 0 : (setq this-command 'pop-to-mark-command)
5655 0 : (pop-to-mark-command))
5656 0 : ((eq last-command 'set-mark-command)
5657 0 : (if (region-active-p)
5658 0 : (progn
5659 0 : (deactivate-mark)
5660 0 : (message "Mark deactivated"))
5661 0 : (activate-mark)
5662 0 : (message "Mark activated")))
5663 : (t
5664 0 : (push-mark-command nil))))
5665 :
5666 : (defun push-mark (&optional location nomsg activate)
5667 : "Set mark at LOCATION (point, by default) and push old mark on mark ring.
5668 : If the last global mark pushed was not in the current buffer,
5669 : also push LOCATION on the global mark ring.
5670 : Display `Mark set' unless the optional second arg NOMSG is non-nil.
5671 :
5672 : Novice Emacs Lisp programmers often try to use the mark for the wrong
5673 : purposes. See the documentation of `set-mark' for more information.
5674 :
5675 : In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil."
5676 2 : (unless (null (mark t))
5677 0 : (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring))
5678 0 : (when (> (length mark-ring) mark-ring-max)
5679 0 : (move-marker (car (nthcdr mark-ring-max mark-ring)) nil)
5680 2 : (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil)))
5681 2 : (set-marker (mark-marker) (or location (point)) (current-buffer))
5682 : ;; Now push the mark on the global mark ring.
5683 2 : (if (and global-mark-ring
5684 2 : (eq (marker-buffer (car global-mark-ring)) (current-buffer)))
5685 : ;; The last global mark pushed was in this same buffer.
5686 : ;; Don't push another one.
5687 : nil
5688 2 : (setq global-mark-ring (cons (copy-marker (mark-marker)) global-mark-ring))
5689 2 : (when (> (length global-mark-ring) global-mark-ring-max)
5690 0 : (move-marker (car (nthcdr global-mark-ring-max global-mark-ring)) nil)
5691 2 : (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil)))
5692 2 : (or nomsg executing-kbd-macro (> (minibuffer-depth) 0)
5693 2 : (message "Mark set"))
5694 2 : (if (or activate (not transient-mark-mode))
5695 2 : (set-mark (mark t)))
5696 : nil)
5697 :
5698 : (defun pop-mark ()
5699 : "Pop off mark ring into the buffer's actual mark.
5700 : Does not set point. Does nothing if mark ring is empty."
5701 0 : (when mark-ring
5702 0 : (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker)))))
5703 0 : (set-marker (mark-marker) (+ 0 (car mark-ring)) (current-buffer))
5704 0 : (move-marker (car mark-ring) nil)
5705 0 : (if (null (mark t)) (ding))
5706 0 : (setq mark-ring (cdr mark-ring)))
5707 0 : (deactivate-mark))
5708 :
5709 : (define-obsolete-function-alias
5710 : 'exchange-dot-and-mark 'exchange-point-and-mark "23.3")
5711 : (defun exchange-point-and-mark (&optional arg)
5712 : "Put the mark where point is now, and point where the mark is now.
5713 : This command works even when the mark is not active,
5714 : and it reactivates the mark.
5715 :
5716 : If Transient Mark mode is on, a prefix ARG deactivates the mark
5717 : if it is active, and otherwise avoids reactivating it. If
5718 : Transient Mark mode is off, a prefix ARG enables Transient Mark
5719 : mode temporarily."
5720 : (interactive "P")
5721 0 : (let ((omark (mark t))
5722 0 : (temp-highlight (eq (car-safe transient-mark-mode) 'only)))
5723 0 : (if (null omark)
5724 0 : (user-error "No mark set in this buffer"))
5725 0 : (set-mark (point))
5726 0 : (goto-char omark)
5727 0 : (cond (temp-highlight
5728 0 : (setq-local transient-mark-mode (cons 'only transient-mark-mode)))
5729 0 : ((or (and arg (region-active-p)) ; (xor arg (not (region-active-p)))
5730 0 : (not (or arg (region-active-p))))
5731 0 : (deactivate-mark))
5732 0 : (t (activate-mark)))
5733 0 : nil))
5734 :
5735 : (defcustom shift-select-mode t
5736 : "When non-nil, shifted motion keys activate the mark momentarily.
5737 :
5738 : While the mark is activated in this way, any shift-translated point
5739 : motion key extends the region, and if Transient Mark mode was off, it
5740 : is temporarily turned on. Furthermore, the mark will be deactivated
5741 : by any subsequent point motion key that was not shift-translated, or
5742 : by any action that normally deactivates the mark in Transient Mark mode.
5743 :
5744 : See `this-command-keys-shift-translated' for the meaning of
5745 : shift-translation."
5746 : :type 'boolean
5747 : :group 'editing-basics)
5748 :
5749 : (defun handle-shift-selection ()
5750 : "Activate/deactivate mark depending on invocation thru shift translation.
5751 : This function is called by `call-interactively' when a command
5752 : with a `^' character in its `interactive' spec is invoked, before
5753 : running the command itself.
5754 :
5755 : If `shift-select-mode' is enabled and the command was invoked
5756 : through shift translation, set the mark and activate the region
5757 : temporarily, unless it was already set in this way. See
5758 : `this-command-keys-shift-translated' for the meaning of shift
5759 : translation.
5760 :
5761 : Otherwise, if the region has been activated temporarily,
5762 : deactivate it, and restore the variable `transient-mark-mode' to
5763 : its earlier value."
5764 0 : (cond ((and shift-select-mode this-command-keys-shift-translated)
5765 0 : (unless (and mark-active
5766 0 : (eq (car-safe transient-mark-mode) 'only))
5767 0 : (setq-local transient-mark-mode
5768 0 : (cons 'only
5769 0 : (unless (eq transient-mark-mode 'lambda)
5770 0 : transient-mark-mode)))
5771 0 : (push-mark nil nil t)))
5772 0 : ((eq (car-safe transient-mark-mode) 'only)
5773 0 : (setq transient-mark-mode (cdr transient-mark-mode))
5774 0 : (if (eq transient-mark-mode (default-value 'transient-mark-mode))
5775 0 : (kill-local-variable 'transient-mark-mode))
5776 0 : (deactivate-mark))))
5777 :
5778 : (define-minor-mode transient-mark-mode
5779 : "Toggle Transient Mark mode.
5780 : With a prefix argument ARG, enable Transient Mark mode if ARG is
5781 : positive, and disable it otherwise. If called from Lisp, enable
5782 : Transient Mark mode if ARG is omitted or nil.
5783 :
5784 : Transient Mark mode is a global minor mode. When enabled, the
5785 : region is highlighted with the `region' face whenever the mark
5786 : is active. The mark is \"deactivated\" by changing the buffer,
5787 : and after certain other operations that set the mark but whose
5788 : main purpose is something else--for example, incremental search,
5789 : \\[beginning-of-buffer], and \\[end-of-buffer].
5790 :
5791 : You can also deactivate the mark by typing \\[keyboard-quit] or
5792 : \\[keyboard-escape-quit].
5793 :
5794 : Many commands change their behavior when Transient Mark mode is
5795 : in effect and the mark is active, by acting on the region instead
5796 : of their usual default part of the buffer's text. Examples of
5797 : such commands include \\[comment-dwim], \\[flush-lines], \\[keep-lines],
5798 : \\[query-replace], \\[query-replace-regexp], \\[ispell], and \\[undo].
5799 : To see the documentation of commands which are sensitive to the
5800 : Transient Mark mode, invoke \\[apropos-documentation] and type \"transient\"
5801 : or \"mark.*active\" at the prompt."
5802 : :global t
5803 : ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
5804 : :variable (default-value 'transient-mark-mode))
5805 :
5806 : (defvar widen-automatically t
5807 : "Non-nil means it is ok for commands to call `widen' when they want to.
5808 : Some commands will do this in order to go to positions outside
5809 : the current accessible part of the buffer.
5810 :
5811 : If `widen-automatically' is nil, these commands will do something else
5812 : as a fallback, and won't change the buffer bounds.")
5813 :
5814 : (defvar non-essential nil
5815 : "Whether the currently executing code is performing an essential task.
5816 : This variable should be non-nil only when running code which should not
5817 : disturb the user. E.g. it can be used to prevent Tramp from prompting the
5818 : user for a password when we are simply scanning a set of files in the
5819 : background or displaying possible completions before the user even asked
5820 : for it.")
5821 :
5822 : (defun pop-global-mark ()
5823 : "Pop off global mark ring and jump to the top location."
5824 : (interactive)
5825 : ;; Pop entries which refer to non-existent buffers.
5826 0 : (while (and global-mark-ring (not (marker-buffer (car global-mark-ring))))
5827 0 : (setq global-mark-ring (cdr global-mark-ring)))
5828 0 : (or global-mark-ring
5829 0 : (error "No global mark set"))
5830 0 : (let* ((marker (car global-mark-ring))
5831 0 : (buffer (marker-buffer marker))
5832 0 : (position (marker-position marker)))
5833 0 : (setq global-mark-ring (nconc (cdr global-mark-ring)
5834 0 : (list (car global-mark-ring))))
5835 0 : (set-buffer buffer)
5836 0 : (or (and (>= position (point-min))
5837 0 : (<= position (point-max)))
5838 0 : (if widen-automatically
5839 0 : (widen)
5840 0 : (error "Global mark position is outside accessible part of buffer")))
5841 0 : (goto-char position)
5842 0 : (switch-to-buffer buffer)))
5843 :
5844 : (defcustom next-line-add-newlines nil
5845 : "If non-nil, `next-line' inserts newline to avoid `end of buffer' error."
5846 : :type 'boolean
5847 : :version "21.1"
5848 : :group 'editing-basics)
5849 :
5850 : (defun next-line (&optional arg try-vscroll)
5851 : "Move cursor vertically down ARG lines.
5852 : Interactively, vscroll tall lines if `auto-window-vscroll' is enabled.
5853 : Non-interactively, use TRY-VSCROLL to control whether to vscroll tall
5854 : lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this
5855 : function will not vscroll.
5856 :
5857 : ARG defaults to 1.
5858 :
5859 : If there is no character in the target line exactly under the current column,
5860 : the cursor is positioned after the character in that line which spans this
5861 : column, or at the end of the line if it is not long enough.
5862 : If there is no line in the buffer after this one, behavior depends on the
5863 : value of `next-line-add-newlines'. If non-nil, it inserts a newline character
5864 : to create a line, and moves the cursor to that line. Otherwise it moves the
5865 : cursor to the end of the buffer.
5866 :
5867 : If the variable `line-move-visual' is non-nil, this command moves
5868 : by display lines. Otherwise, it moves by buffer lines, without
5869 : taking variable-width characters or continued lines into account.
5870 : See \\[next-logical-line] for a command that always moves by buffer lines.
5871 :
5872 : The command \\[set-goal-column] can be used to create
5873 : a semipermanent goal column for this command.
5874 : Then instead of trying to move exactly vertically (or as close as possible),
5875 : this command moves to the specified goal column (or as close as possible).
5876 : The goal column is stored in the variable `goal-column', which is nil
5877 : when there is no goal column. Note that setting `goal-column'
5878 : overrides `line-move-visual' and causes this command to move by buffer
5879 : lines rather than by display lines."
5880 : (declare (interactive-only forward-line))
5881 : (interactive "^p\np")
5882 0 : (or arg (setq arg 1))
5883 0 : (if (and next-line-add-newlines (= arg 1))
5884 0 : (if (save-excursion (end-of-line) (eobp))
5885 : ;; When adding a newline, don't expand an abbrev.
5886 0 : (let ((abbrev-mode nil))
5887 0 : (end-of-line)
5888 0 : (insert (if use-hard-newlines hard-newline "\n")))
5889 0 : (line-move arg nil nil try-vscroll))
5890 0 : (if (called-interactively-p 'interactive)
5891 0 : (condition-case err
5892 0 : (line-move arg nil nil try-vscroll)
5893 : ((beginning-of-buffer end-of-buffer)
5894 0 : (signal (car err) (cdr err))))
5895 0 : (line-move arg nil nil try-vscroll)))
5896 : nil)
5897 :
5898 : (defun previous-line (&optional arg try-vscroll)
5899 : "Move cursor vertically up ARG lines.
5900 : Interactively, vscroll tall lines if `auto-window-vscroll' is enabled.
5901 : Non-interactively, use TRY-VSCROLL to control whether to vscroll tall
5902 : lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this
5903 : function will not vscroll.
5904 :
5905 : ARG defaults to 1.
5906 :
5907 : If there is no character in the target line exactly over the current column,
5908 : the cursor is positioned after the character in that line which spans this
5909 : column, or at the end of the line if it is not long enough.
5910 :
5911 : If the variable `line-move-visual' is non-nil, this command moves
5912 : by display lines. Otherwise, it moves by buffer lines, without
5913 : taking variable-width characters or continued lines into account.
5914 : See \\[previous-logical-line] for a command that always moves by buffer lines.
5915 :
5916 : The command \\[set-goal-column] can be used to create
5917 : a semipermanent goal column for this command.
5918 : Then instead of trying to move exactly vertically (or as close as possible),
5919 : this command moves to the specified goal column (or as close as possible).
5920 : The goal column is stored in the variable `goal-column', which is nil
5921 : when there is no goal column. Note that setting `goal-column'
5922 : overrides `line-move-visual' and causes this command to move by buffer
5923 : lines rather than by display lines."
5924 : (declare (interactive-only
5925 : "use `forward-line' with negative argument instead."))
5926 : (interactive "^p\np")
5927 0 : (or arg (setq arg 1))
5928 0 : (if (called-interactively-p 'interactive)
5929 0 : (condition-case err
5930 0 : (line-move (- arg) nil nil try-vscroll)
5931 : ((beginning-of-buffer end-of-buffer)
5932 0 : (signal (car err) (cdr err))))
5933 0 : (line-move (- arg) nil nil try-vscroll))
5934 : nil)
5935 :
5936 : (defcustom track-eol nil
5937 : "Non-nil means vertical motion starting at end of line keeps to ends of lines.
5938 : This means moving to the end of each line moved onto.
5939 : The beginning of a blank line does not count as the end of a line.
5940 : This has no effect when the variable `line-move-visual' is non-nil."
5941 : :type 'boolean
5942 : :group 'editing-basics)
5943 :
5944 : (defcustom goal-column nil
5945 : "Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil.
5946 : A non-nil setting overrides the variable `line-move-visual', which see."
5947 : :type '(choice integer
5948 : (const :tag "None" nil))
5949 : :group 'editing-basics)
5950 : (make-variable-buffer-local 'goal-column)
5951 :
5952 : (defvar temporary-goal-column 0
5953 : "Current goal column for vertical motion.
5954 : It is the column where point was at the start of the current run
5955 : of vertical motion commands.
5956 :
5957 : When moving by visual lines via the function `line-move-visual', it is a cons
5958 : cell (COL . HSCROLL), where COL is the x-position, in pixels,
5959 : divided by the default column width, and HSCROLL is the number of
5960 : columns by which window is scrolled from left margin.
5961 :
5962 : When the `track-eol' feature is doing its job, the value is
5963 : `most-positive-fixnum'.")
5964 :
5965 : (defvar last--line-number-width 0
5966 : "Last value of width used for displaying line numbers.
5967 : Used internally by `line-move-visual'.")
5968 :
5969 : (defcustom line-move-ignore-invisible t
5970 : "Non-nil means commands that move by lines ignore invisible newlines.
5971 : When this option is non-nil, \\[next-line], \\[previous-line], \\[move-end-of-line], and \\[move-beginning-of-line] behave
5972 : as if newlines that are invisible didn't exist, and count
5973 : only visible newlines. Thus, moving across across 2 newlines
5974 : one of which is invisible will be counted as a one-line move.
5975 : Also, a non-nil value causes invisible text to be ignored when
5976 : counting columns for the purposes of keeping point in the same
5977 : column by \\[next-line] and \\[previous-line].
5978 :
5979 : Outline mode sets this."
5980 : :type 'boolean
5981 : :group 'editing-basics)
5982 :
5983 : (defcustom line-move-visual t
5984 : "When non-nil, `line-move' moves point by visual lines.
5985 : This movement is based on where the cursor is displayed on the
5986 : screen, instead of relying on buffer contents alone. It takes
5987 : into account variable-width characters and line continuation.
5988 : If nil, `line-move' moves point by logical lines.
5989 : A non-nil setting of `goal-column' overrides the value of this variable
5990 : and forces movement by logical lines.
5991 : A window that is horizontally scrolled also forces movement by logical
5992 : lines."
5993 : :type 'boolean
5994 : :group 'editing-basics
5995 : :version "23.1")
5996 :
5997 : ;; Only used if display-graphic-p.
5998 : (declare-function font-info "font.c" (name &optional frame))
5999 :
6000 : (defun default-font-height ()
6001 : "Return the height in pixels of the current buffer's default face font.
6002 :
6003 : If the default font is remapped (see `face-remapping-alist'), the
6004 : function returns the height of the remapped face."
6005 0 : (let ((default-font (face-font 'default)))
6006 0 : (cond
6007 0 : ((and (display-multi-font-p)
6008 : ;; Avoid calling font-info if the frame's default font was
6009 : ;; not changed since the frame was created. That's because
6010 : ;; font-info is expensive for some fonts, see bug #14838.
6011 0 : (not (string= (frame-parameter nil 'font) default-font)))
6012 0 : (aref (font-info default-font) 3))
6013 0 : (t (frame-char-height)))))
6014 :
6015 : (defun default-font-width ()
6016 : "Return the width in pixels of the current buffer's default face font.
6017 :
6018 : If the default font is remapped (see `face-remapping-alist'), the
6019 : function returns the width of the remapped face."
6020 0 : (let ((default-font (face-font 'default)))
6021 0 : (cond
6022 0 : ((and (display-multi-font-p)
6023 : ;; Avoid calling font-info if the frame's default font was
6024 : ;; not changed since the frame was created. That's because
6025 : ;; font-info is expensive for some fonts, see bug #14838.
6026 0 : (not (string= (frame-parameter nil 'font) default-font)))
6027 0 : (let* ((info (font-info (face-font 'default)))
6028 0 : (width (aref info 11)))
6029 0 : (if (> width 0)
6030 0 : width
6031 0 : (aref info 10))))
6032 0 : (t (frame-char-width)))))
6033 :
6034 : (defun default-line-height ()
6035 : "Return the pixel height of current buffer's default-face text line.
6036 :
6037 : The value includes `line-spacing', if any, defined for the buffer
6038 : or the frame."
6039 0 : (let ((dfh (default-font-height))
6040 0 : (lsp (if (display-graphic-p)
6041 0 : (or line-spacing
6042 0 : (default-value 'line-spacing)
6043 0 : (frame-parameter nil 'line-spacing)
6044 0 : 0)
6045 0 : 0)))
6046 0 : (if (floatp lsp)
6047 0 : (setq lsp (truncate (* (frame-char-height) lsp))))
6048 0 : (+ dfh lsp)))
6049 :
6050 : (defun window-screen-lines ()
6051 : "Return the number of screen lines in the text area of the selected window.
6052 :
6053 : This is different from `window-text-height' in that this function counts
6054 : lines in units of the height of the font used by the default face displayed
6055 : in the window, not in units of the frame's default font, and also accounts
6056 : for `line-spacing', if any, defined for the window's buffer or frame.
6057 :
6058 : The value is a floating-point number."
6059 0 : (let ((edges (window-inside-pixel-edges))
6060 0 : (dlh (default-line-height)))
6061 0 : (/ (float (- (nth 3 edges) (nth 1 edges))) dlh)))
6062 :
6063 : ;; Returns non-nil if partial move was done.
6064 : (defun line-move-partial (arg noerror &optional _to-end)
6065 0 : (if (< arg 0)
6066 : ;; Move backward (up).
6067 : ;; If already vscrolled, reduce vscroll
6068 0 : (let ((vs (window-vscroll nil t))
6069 0 : (dlh (default-line-height)))
6070 0 : (when (> vs dlh)
6071 0 : (set-window-vscroll nil (- vs dlh) t)))
6072 :
6073 : ;; Move forward (down).
6074 0 : (let* ((lh (window-line-height -1))
6075 0 : (rowh (car lh))
6076 0 : (vpos (nth 1 lh))
6077 0 : (ypos (nth 2 lh))
6078 0 : (rbot (nth 3 lh))
6079 0 : (this-lh (window-line-height))
6080 0 : (this-height (car this-lh))
6081 0 : (this-ypos (nth 2 this-lh))
6082 0 : (dlh (default-line-height))
6083 0 : (wslines (window-screen-lines))
6084 0 : (edges (window-inside-pixel-edges))
6085 0 : (winh (- (nth 3 edges) (nth 1 edges) 1))
6086 : py vs last-line)
6087 0 : (if (> (mod wslines 1.0) 0.0)
6088 0 : (setq wslines (round (+ wslines 0.5))))
6089 0 : (when (or (null lh)
6090 0 : (>= rbot dlh)
6091 0 : (<= ypos (- dlh))
6092 0 : (null this-lh)
6093 0 : (<= this-ypos (- dlh)))
6094 0 : (unless lh
6095 0 : (let ((wend (pos-visible-in-window-p t nil t)))
6096 0 : (setq rbot (nth 3 wend)
6097 0 : rowh (nth 4 wend)
6098 0 : vpos (nth 5 wend))))
6099 0 : (unless this-lh
6100 0 : (let ((wstart (pos-visible-in-window-p nil nil t)))
6101 0 : (setq this-ypos (nth 2 wstart)
6102 0 : this-height (nth 4 wstart))))
6103 0 : (setq py
6104 0 : (or (nth 1 this-lh)
6105 0 : (let ((ppos (posn-at-point))
6106 : col-row)
6107 0 : (setq col-row (posn-actual-col-row ppos))
6108 0 : (if col-row
6109 0 : (- (cdr col-row) (window-vscroll))
6110 0 : (cdr (posn-col-row ppos))))))
6111 : ;; VPOS > 0 means the last line is only partially visible.
6112 : ;; But if the part that is visible is at least as tall as the
6113 : ;; default font, that means the line is actually fully
6114 : ;; readable, and something like line-spacing is hidden. So in
6115 : ;; that case we accept the last line in the window as still
6116 : ;; visible, and consider the margin as starting one line
6117 : ;; later.
6118 0 : (if (and vpos (> vpos 0))
6119 0 : (if (and rowh
6120 0 : (>= rowh (default-font-height))
6121 0 : (< rowh dlh))
6122 0 : (setq last-line (min (- wslines scroll-margin) vpos))
6123 0 : (setq last-line (min (- wslines scroll-margin 1) (1- vpos)))))
6124 0 : (cond
6125 : ;; If last line of window is fully visible, and vscrolling
6126 : ;; more would make this line invisible, move forward.
6127 0 : ((and (or (< (setq vs (window-vscroll nil t)) dlh)
6128 0 : (null this-height)
6129 0 : (<= this-height dlh))
6130 0 : (or (null rbot) (= rbot 0)))
6131 : nil)
6132 : ;; If cursor is not in the bottom scroll margin, and the
6133 : ;; current line is is not too tall, move forward.
6134 0 : ((and (or (null this-height) (<= this-height winh))
6135 0 : vpos
6136 0 : (> vpos 0)
6137 0 : (< py last-line))
6138 : nil)
6139 : ;; When already vscrolled, we vscroll some more if we can,
6140 : ;; or clear vscroll and move forward at end of tall image.
6141 0 : ((> vs 0)
6142 0 : (when (or (and rbot (> rbot 0))
6143 0 : (and this-height (> this-height dlh)))
6144 0 : (set-window-vscroll nil (+ vs dlh) t)))
6145 : ;; If cursor just entered the bottom scroll margin, move forward,
6146 : ;; but also optionally vscroll one line so redisplay won't recenter.
6147 0 : ((and vpos
6148 0 : (> vpos 0)
6149 0 : (= py last-line))
6150 : ;; Don't vscroll if the partially-visible line at window
6151 : ;; bottom is not too tall (a.k.a. "just one more text
6152 : ;; line"): in that case, we do want redisplay to behave
6153 : ;; normally, i.e. recenter or whatever.
6154 : ;;
6155 : ;; Note: ROWH + RBOT from the value returned by
6156 : ;; pos-visible-in-window-p give the total height of the
6157 : ;; partially-visible glyph row at the end of the window. As
6158 : ;; we are dealing with floats, we disregard sub-pixel
6159 : ;; discrepancies between that and DLH.
6160 0 : (if (and rowh rbot (>= (- (+ rowh rbot) winh) 1))
6161 0 : (set-window-vscroll nil dlh t))
6162 0 : (line-move-1 arg noerror)
6163 : t)
6164 : ;; If there are lines above the last line, scroll-up one line.
6165 0 : ((and vpos (> vpos 0))
6166 0 : (scroll-up 1)
6167 : t)
6168 : ;; Finally, start vscroll.
6169 : (t
6170 0 : (set-window-vscroll nil dlh t)))))))
6171 :
6172 :
6173 : ;; This is like line-move-1 except that it also performs
6174 : ;; vertical scrolling of tall images if appropriate.
6175 : ;; That is not really a clean thing to do, since it mixes
6176 : ;; scrolling with cursor motion. But so far we don't have
6177 : ;; a cleaner solution to the problem of making C-n do something
6178 : ;; useful given a tall image.
6179 : (defun line-move (arg &optional noerror _to-end try-vscroll)
6180 : "Move forward ARG lines.
6181 : If NOERROR, don't signal an error if we can't move ARG lines.
6182 : TO-END is unused.
6183 : TRY-VSCROLL controls whether to vscroll tall lines: if either
6184 : `auto-window-vscroll' or TRY-VSCROLL is nil, this function will
6185 : not vscroll."
6186 0 : (if noninteractive
6187 0 : (line-move-1 arg noerror)
6188 0 : (unless (and auto-window-vscroll try-vscroll
6189 : ;; Only vscroll for single line moves
6190 0 : (= (abs arg) 1)
6191 : ;; Under scroll-conservatively, the display engine
6192 : ;; does this better.
6193 0 : (zerop scroll-conservatively)
6194 : ;; But don't vscroll in a keyboard macro.
6195 0 : (not defining-kbd-macro)
6196 0 : (not executing-kbd-macro)
6197 0 : (line-move-partial arg noerror))
6198 0 : (set-window-vscroll nil 0 t)
6199 0 : (if (and line-move-visual
6200 : ;; Display-based column are incompatible with goal-column.
6201 0 : (not goal-column)
6202 : ;; When the text in the window is scrolled to the left,
6203 : ;; display-based motion doesn't make sense (because each
6204 : ;; logical line occupies exactly one screen line).
6205 0 : (not (> (window-hscroll) 0))
6206 : ;; Likewise when the text _was_ scrolled to the left
6207 : ;; when the current run of vertical motion commands
6208 : ;; started.
6209 0 : (not (and (memq last-command
6210 0 : `(next-line previous-line ,this-command))
6211 0 : auto-hscroll-mode
6212 0 : (numberp temporary-goal-column)
6213 0 : (>= temporary-goal-column
6214 0 : (- (window-width) hscroll-margin)))))
6215 0 : (prog1 (line-move-visual arg noerror)
6216 : ;; If we moved into a tall line, set vscroll to make
6217 : ;; scrolling through tall images more smooth.
6218 0 : (let ((lh (line-pixel-height))
6219 0 : (edges (window-inside-pixel-edges))
6220 0 : (dlh (default-line-height))
6221 : winh)
6222 0 : (setq winh (- (nth 3 edges) (nth 1 edges) 1))
6223 0 : (if (and (< arg 0)
6224 0 : (< (point) (window-start))
6225 0 : (> lh winh))
6226 0 : (set-window-vscroll
6227 : nil
6228 0 : (- lh dlh) t))))
6229 0 : (line-move-1 arg noerror)))))
6230 :
6231 : ;; Display-based alternative to line-move-1.
6232 : ;; Arg says how many lines to move. The value is t if we can move the
6233 : ;; specified number of lines.
6234 : (defun line-move-visual (arg &optional noerror)
6235 : "Move ARG lines forward.
6236 : If NOERROR, don't signal an error if we can't move that many lines."
6237 0 : (let ((opoint (point))
6238 0 : (hscroll (window-hscroll))
6239 0 : (lnum-width (line-number-display-width t))
6240 : target-hscroll)
6241 : ;; Check if the previous command was a line-motion command, or if
6242 : ;; we were called from some other command.
6243 0 : (if (and (consp temporary-goal-column)
6244 0 : (memq last-command `(next-line previous-line ,this-command)))
6245 : ;; If so, there's no need to reset `temporary-goal-column',
6246 : ;; but we may need to hscroll.
6247 0 : (progn
6248 0 : (if (or (/= (cdr temporary-goal-column) hscroll)
6249 0 : (> (cdr temporary-goal-column) 0))
6250 0 : (setq target-hscroll (cdr temporary-goal-column)))
6251 : ;; Update the COLUMN part of temporary-goal-column if the
6252 : ;; line-number display changed its width since the last
6253 : ;; time.
6254 0 : (setq temporary-goal-column
6255 0 : (cons (+ (car temporary-goal-column)
6256 0 : (/ (float (- lnum-width last--line-number-width))
6257 0 : (frame-char-width)))
6258 0 : (cdr temporary-goal-column)))
6259 0 : (setq last--line-number-width lnum-width))
6260 : ;; Otherwise, we should reset `temporary-goal-column'.
6261 0 : (let ((posn (posn-at-point))
6262 : x-pos)
6263 0 : (cond
6264 : ;; Handle the `overflow-newline-into-fringe' case
6265 : ;; (left-fringe is for the R2L case):
6266 0 : ((memq (nth 1 posn) '(right-fringe left-fringe))
6267 0 : (setq temporary-goal-column (cons (window-width) hscroll)))
6268 0 : ((car (posn-x-y posn))
6269 0 : (setq x-pos (car (posn-x-y posn)))
6270 : ;; In R2L lines, the X pixel coordinate is measured from the
6271 : ;; left edge of the window, but columns are still counted
6272 : ;; from the logical-order beginning of the line, i.e. from
6273 : ;; the right edge in this case. We need to adjust for that.
6274 0 : (if (eq (current-bidi-paragraph-direction) 'right-to-left)
6275 0 : (setq x-pos (- (window-body-width nil t) 1 x-pos)))
6276 0 : (setq temporary-goal-column
6277 0 : (cons (/ (float x-pos)
6278 0 : (frame-char-width))
6279 0 : hscroll)))
6280 0 : (executing-kbd-macro
6281 : ;; When we move beyond the first/last character visible in
6282 : ;; the window, posn-at-point will return nil, so we need to
6283 : ;; approximate the goal column as below.
6284 0 : (setq temporary-goal-column
6285 0 : (mod (current-column) (window-text-width)))))))
6286 0 : (if target-hscroll
6287 0 : (set-window-hscroll (selected-window) target-hscroll))
6288 : ;; vertical-motion can move more than it was asked to if it moves
6289 : ;; across display strings with newlines. We don't want to ring
6290 : ;; the bell and announce beginning/end of buffer in that case.
6291 0 : (or (and (or (and (>= arg 0)
6292 0 : (>= (vertical-motion
6293 0 : (cons (or goal-column
6294 0 : (if (consp temporary-goal-column)
6295 0 : (car temporary-goal-column)
6296 0 : temporary-goal-column))
6297 0 : arg))
6298 0 : arg))
6299 0 : (and (< arg 0)
6300 0 : (<= (vertical-motion
6301 0 : (cons (or goal-column
6302 0 : (if (consp temporary-goal-column)
6303 0 : (car temporary-goal-column)
6304 0 : temporary-goal-column))
6305 0 : arg))
6306 0 : arg)))
6307 0 : (or (>= arg 0)
6308 0 : (/= (point) opoint)
6309 : ;; If the goal column lies on a display string,
6310 : ;; `vertical-motion' advances the cursor to the end
6311 : ;; of the string. For arg < 0, this can cause the
6312 : ;; cursor to get stuck. (Bug#3020).
6313 0 : (= (vertical-motion arg) arg)))
6314 0 : (unless noerror
6315 0 : (signal (if (< arg 0) 'beginning-of-buffer 'end-of-buffer)
6316 0 : nil)))))
6317 :
6318 : ;; This is the guts of next-line and previous-line.
6319 : ;; Arg says how many lines to move.
6320 : ;; The value is t if we can move the specified number of lines.
6321 : (defun line-move-1 (arg &optional noerror _to-end)
6322 : ;; Don't run any point-motion hooks, and disregard intangibility,
6323 : ;; for intermediate positions.
6324 0 : (let ((inhibit-point-motion-hooks t)
6325 0 : (opoint (point))
6326 0 : (orig-arg arg))
6327 0 : (if (consp temporary-goal-column)
6328 0 : (setq temporary-goal-column (+ (car temporary-goal-column)
6329 0 : (cdr temporary-goal-column))))
6330 0 : (unwind-protect
6331 0 : (progn
6332 0 : (if (not (memq last-command '(next-line previous-line)))
6333 0 : (setq temporary-goal-column
6334 0 : (if (and track-eol (eolp)
6335 : ;; Don't count beg of empty line as end of line
6336 : ;; unless we just did explicit end-of-line.
6337 0 : (or (not (bolp)) (eq last-command 'move-end-of-line)))
6338 0 : most-positive-fixnum
6339 0 : (current-column))))
6340 :
6341 0 : (if (not (or (integerp selective-display)
6342 0 : line-move-ignore-invisible))
6343 : ;; Use just newline characters.
6344 : ;; Set ARG to 0 if we move as many lines as requested.
6345 0 : (or (if (> arg 0)
6346 0 : (progn (if (> arg 1) (forward-line (1- arg)))
6347 : ;; This way of moving forward ARG lines
6348 : ;; verifies that we have a newline after the last one.
6349 : ;; It doesn't get confused by intangible text.
6350 0 : (end-of-line)
6351 0 : (if (zerop (forward-line 1))
6352 0 : (setq arg 0)))
6353 0 : (and (zerop (forward-line arg))
6354 0 : (bolp)
6355 0 : (setq arg 0)))
6356 0 : (unless noerror
6357 0 : (signal (if (< arg 0)
6358 : 'beginning-of-buffer
6359 0 : 'end-of-buffer)
6360 0 : nil)))
6361 : ;; Move by arg lines, but ignore invisible ones.
6362 0 : (let (done)
6363 0 : (while (and (> arg 0) (not done))
6364 : ;; If the following character is currently invisible,
6365 : ;; skip all characters with that same `invisible' property value.
6366 0 : (while (and (not (eobp)) (invisible-p (point)))
6367 0 : (goto-char (next-char-property-change (point))))
6368 : ;; Move a line.
6369 : ;; We don't use `end-of-line', since we want to escape
6370 : ;; from field boundaries occurring exactly at point.
6371 0 : (goto-char (constrain-to-field
6372 0 : (let ((inhibit-field-text-motion t))
6373 0 : (line-end-position))
6374 0 : (point) t t
6375 0 : 'inhibit-line-move-field-capture))
6376 : ;; If there's no invisibility here, move over the newline.
6377 0 : (cond
6378 0 : ((eobp)
6379 0 : (if (not noerror)
6380 0 : (signal 'end-of-buffer nil)
6381 0 : (setq done t)))
6382 0 : ((and (> arg 1) ;; Use vertical-motion for last move
6383 0 : (not (integerp selective-display))
6384 0 : (not (invisible-p (point))))
6385 : ;; We avoid vertical-motion when possible
6386 : ;; because that has to fontify.
6387 0 : (forward-line 1))
6388 : ;; Otherwise move a more sophisticated way.
6389 0 : ((zerop (vertical-motion 1))
6390 0 : (if (not noerror)
6391 0 : (signal 'end-of-buffer nil)
6392 0 : (setq done t))))
6393 0 : (unless done
6394 0 : (setq arg (1- arg))))
6395 : ;; The logic of this is the same as the loop above,
6396 : ;; it just goes in the other direction.
6397 0 : (while (and (< arg 0) (not done))
6398 : ;; For completely consistency with the forward-motion
6399 : ;; case, we should call beginning-of-line here.
6400 : ;; However, if point is inside a field and on a
6401 : ;; continued line, the call to (vertical-motion -1)
6402 : ;; below won't move us back far enough; then we return
6403 : ;; to the same column in line-move-finish, and point
6404 : ;; gets stuck -- cyd
6405 0 : (forward-line 0)
6406 0 : (cond
6407 0 : ((bobp)
6408 0 : (if (not noerror)
6409 0 : (signal 'beginning-of-buffer nil)
6410 0 : (setq done t)))
6411 0 : ((and (< arg -1) ;; Use vertical-motion for last move
6412 0 : (not (integerp selective-display))
6413 0 : (not (invisible-p (1- (point)))))
6414 0 : (forward-line -1))
6415 0 : ((zerop (vertical-motion -1))
6416 0 : (if (not noerror)
6417 0 : (signal 'beginning-of-buffer nil)
6418 0 : (setq done t))))
6419 0 : (unless done
6420 0 : (setq arg (1+ arg))
6421 0 : (while (and ;; Don't move over previous invis lines
6422 : ;; if our target is the middle of this line.
6423 0 : (or (zerop (or goal-column temporary-goal-column))
6424 0 : (< arg 0))
6425 0 : (not (bobp)) (invisible-p (1- (point))))
6426 0 : (goto-char (previous-char-property-change (point))))))))
6427 : ;; This is the value the function returns.
6428 0 : (= arg 0))
6429 :
6430 0 : (cond ((> arg 0)
6431 : ;; If we did not move down as far as desired, at least go
6432 : ;; to end of line. Be sure to call point-entered and
6433 : ;; point-left-hooks.
6434 0 : (let* ((npoint (prog1 (line-end-position)
6435 0 : (goto-char opoint)))
6436 : (inhibit-point-motion-hooks nil))
6437 0 : (goto-char npoint)))
6438 0 : ((< arg 0)
6439 : ;; If we did not move up as far as desired,
6440 : ;; at least go to beginning of line.
6441 0 : (let* ((npoint (prog1 (line-beginning-position)
6442 0 : (goto-char opoint)))
6443 : (inhibit-point-motion-hooks nil))
6444 0 : (goto-char npoint)))
6445 : (t
6446 0 : (line-move-finish (or goal-column temporary-goal-column)
6447 0 : opoint (> orig-arg 0)))))))
6448 :
6449 : (defun line-move-finish (column opoint forward)
6450 0 : (let ((repeat t))
6451 0 : (while repeat
6452 : ;; Set REPEAT to t to repeat the whole thing.
6453 0 : (setq repeat nil)
6454 :
6455 0 : (let (new
6456 0 : (old (point))
6457 0 : (line-beg (line-beginning-position))
6458 : (line-end
6459 : ;; Compute the end of the line
6460 : ;; ignoring effectively invisible newlines.
6461 0 : (save-excursion
6462 : ;; Like end-of-line but ignores fields.
6463 0 : (skip-chars-forward "^\n")
6464 0 : (while (and (not (eobp)) (invisible-p (point)))
6465 0 : (goto-char (next-char-property-change (point)))
6466 0 : (skip-chars-forward "^\n"))
6467 0 : (point))))
6468 :
6469 : ;; Move to the desired column.
6470 0 : (if (and line-move-visual
6471 0 : (not (or truncate-lines truncate-partial-width-windows)))
6472 : ;; Under line-move-visual, goal-column should be
6473 : ;; interpreted in units of the frame's canonical character
6474 : ;; width, which is exactly what vertical-motion does.
6475 0 : (vertical-motion (cons column 0))
6476 0 : (line-move-to-column (truncate column)))
6477 :
6478 : ;; Corner case: suppose we start out in a field boundary in
6479 : ;; the middle of a continued line. When we get to
6480 : ;; line-move-finish, point is at the start of a new *screen*
6481 : ;; line but the same text line; then line-move-to-column would
6482 : ;; move us backwards. Test using C-n with point on the "x" in
6483 : ;; (insert "a" (propertize "x" 'field t) (make-string 89 ?y))
6484 0 : (and forward
6485 0 : (< (point) old)
6486 0 : (goto-char old))
6487 :
6488 0 : (setq new (point))
6489 :
6490 : ;; Process intangibility within a line.
6491 : ;; With inhibit-point-motion-hooks bound to nil, a call to
6492 : ;; goto-char moves point past intangible text.
6493 :
6494 : ;; However, inhibit-point-motion-hooks controls both the
6495 : ;; intangibility and the point-entered/point-left hooks. The
6496 : ;; following hack avoids calling the point-* hooks
6497 : ;; unnecessarily. Note that we move *forward* past intangible
6498 : ;; text when the initial and final points are the same.
6499 0 : (goto-char new)
6500 0 : (let ((inhibit-point-motion-hooks nil))
6501 0 : (goto-char new)
6502 :
6503 : ;; If intangibility moves us to a different (later) place
6504 : ;; in the same line, use that as the destination.
6505 0 : (if (<= (point) line-end)
6506 0 : (setq new (point))
6507 : ;; If that position is "too late",
6508 : ;; try the previous allowable position.
6509 : ;; See if it is ok.
6510 0 : (backward-char)
6511 0 : (if (if forward
6512 : ;; If going forward, don't accept the previous
6513 : ;; allowable position if it is before the target line.
6514 0 : (< line-beg (point))
6515 : ;; If going backward, don't accept the previous
6516 : ;; allowable position if it is still after the target line.
6517 0 : (<= (point) line-end))
6518 0 : (setq new (point))
6519 : ;; As a last resort, use the end of the line.
6520 0 : (setq new line-end))))
6521 :
6522 : ;; Now move to the updated destination, processing fields
6523 : ;; as well as intangibility.
6524 0 : (goto-char opoint)
6525 0 : (let ((inhibit-point-motion-hooks nil))
6526 0 : (goto-char
6527 : ;; Ignore field boundaries if the initial and final
6528 : ;; positions have the same `field' property, even if the
6529 : ;; fields are non-contiguous. This seems to be "nicer"
6530 : ;; behavior in many situations.
6531 0 : (if (eq (get-char-property new 'field)
6532 0 : (get-char-property opoint 'field))
6533 0 : new
6534 0 : (constrain-to-field new opoint t t
6535 0 : 'inhibit-line-move-field-capture))))
6536 :
6537 : ;; If all this moved us to a different line,
6538 : ;; retry everything within that new line.
6539 0 : (when (or (< (point) line-beg) (> (point) line-end))
6540 : ;; Repeat the intangibility and field processing.
6541 0 : (setq repeat t))))))
6542 :
6543 : (defun line-move-to-column (col)
6544 : "Try to find column COL, considering invisibility.
6545 : This function works only in certain cases,
6546 : because what we really need is for `move-to-column'
6547 : and `current-column' to be able to ignore invisible text."
6548 0 : (if (zerop col)
6549 0 : (beginning-of-line)
6550 0 : (move-to-column col))
6551 :
6552 0 : (when (and line-move-ignore-invisible
6553 0 : (not (bolp)) (invisible-p (1- (point))))
6554 0 : (let ((normal-location (point))
6555 0 : (normal-column (current-column)))
6556 : ;; If the following character is currently invisible,
6557 : ;; skip all characters with that same `invisible' property value.
6558 0 : (while (and (not (eobp))
6559 0 : (invisible-p (point)))
6560 0 : (goto-char (next-char-property-change (point))))
6561 : ;; Have we advanced to a larger column position?
6562 0 : (if (> (current-column) normal-column)
6563 : ;; We have made some progress towards the desired column.
6564 : ;; See if we can make any further progress.
6565 0 : (line-move-to-column (+ (current-column) (- col normal-column)))
6566 : ;; Otherwise, go to the place we originally found
6567 : ;; and move back over invisible text.
6568 : ;; that will get us to the same place on the screen
6569 : ;; but with a more reasonable buffer position.
6570 0 : (goto-char normal-location)
6571 0 : (let ((line-beg
6572 : ;; We want the real line beginning, so it's consistent
6573 : ;; with bolp below, otherwise we might infloop.
6574 0 : (let ((inhibit-field-text-motion t))
6575 0 : (line-beginning-position))))
6576 0 : (while (and (not (bolp)) (invisible-p (1- (point))))
6577 0 : (goto-char (previous-char-property-change (point) line-beg))))))))
6578 :
6579 : (defun move-end-of-line (arg)
6580 : "Move point to end of current line as displayed.
6581 : With argument ARG not nil or 1, move forward ARG - 1 lines first.
6582 : If point reaches the beginning or end of buffer, it stops there.
6583 :
6584 : To ignore the effects of the `intangible' text or overlay
6585 : property, bind `inhibit-point-motion-hooks' to t.
6586 : If there is an image in the current line, this function
6587 : disregards newlines that are part of the text on which the image
6588 : rests."
6589 : (interactive "^p")
6590 0 : (or arg (setq arg 1))
6591 0 : (let (done)
6592 0 : (while (not done)
6593 0 : (let ((newpos
6594 0 : (save-excursion
6595 0 : (let ((goal-column 0)
6596 : (line-move-visual nil))
6597 0 : (and (line-move arg t)
6598 : ;; With bidi reordering, we may not be at bol,
6599 : ;; so make sure we are.
6600 0 : (skip-chars-backward "^\n")
6601 0 : (not (bobp))
6602 0 : (progn
6603 0 : (while (and (not (bobp)) (invisible-p (1- (point))))
6604 0 : (goto-char (previous-single-char-property-change
6605 0 : (point) 'invisible)))
6606 0 : (backward-char 1)))
6607 0 : (point)))))
6608 0 : (goto-char newpos)
6609 0 : (if (and (> (point) newpos)
6610 0 : (eq (preceding-char) ?\n))
6611 0 : (backward-char 1)
6612 0 : (if (and (> (point) newpos) (not (eobp))
6613 0 : (not (eq (following-char) ?\n)))
6614 : ;; If we skipped something intangible and now we're not
6615 : ;; really at eol, keep going.
6616 0 : (setq arg 1)
6617 0 : (setq done t)))))))
6618 :
6619 : (defun move-beginning-of-line (arg)
6620 : "Move point to beginning of current line as displayed.
6621 : \(If there's an image in the line, this disregards newlines
6622 : which are part of the text that the image rests on.)
6623 :
6624 : With argument ARG not nil or 1, move forward ARG - 1 lines first.
6625 : If point reaches the beginning or end of buffer, it stops there.
6626 : \(But if the buffer doesn't end in a newline, it stops at the
6627 : beginning of the last line.)
6628 : To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6629 : (interactive "^p")
6630 0 : (or arg (setq arg 1))
6631 :
6632 0 : (let ((orig (point))
6633 : first-vis first-vis-field-value)
6634 :
6635 : ;; Move by lines, if ARG is not 1 (the default).
6636 0 : (if (/= arg 1)
6637 0 : (let ((line-move-visual nil))
6638 0 : (line-move (1- arg) t)))
6639 :
6640 : ;; Move to beginning-of-line, ignoring fields and invisible text.
6641 0 : (skip-chars-backward "^\n")
6642 0 : (while (and (not (bobp)) (invisible-p (1- (point))))
6643 0 : (goto-char (previous-char-property-change (point)))
6644 0 : (skip-chars-backward "^\n"))
6645 :
6646 : ;; Now find first visible char in the line.
6647 0 : (while (and (< (point) orig) (invisible-p (point)))
6648 0 : (goto-char (next-char-property-change (point) orig)))
6649 0 : (setq first-vis (point))
6650 :
6651 : ;; See if fields would stop us from reaching FIRST-VIS.
6652 0 : (setq first-vis-field-value
6653 0 : (constrain-to-field first-vis orig (/= arg 1) t nil))
6654 :
6655 0 : (goto-char (if (/= first-vis-field-value first-vis)
6656 : ;; If yes, obey them.
6657 0 : first-vis-field-value
6658 : ;; Otherwise, move to START with attention to fields.
6659 : ;; (It is possible that fields never matter in this case.)
6660 0 : (constrain-to-field (point) orig
6661 0 : (/= arg 1) t nil)))))
6662 :
6663 :
6664 : ;; Many people have said they rarely use this feature, and often type
6665 : ;; it by accident. Maybe it shouldn't even be on a key.
6666 : (put 'set-goal-column 'disabled t)
6667 :
6668 : (defun set-goal-column (arg)
6669 : "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line].
6670 : Those commands will move to this position in the line moved to
6671 : rather than trying to keep the same horizontal position.
6672 : With a non-nil argument ARG, clears out the goal column
6673 : so that \\[next-line] and \\[previous-line] resume vertical motion.
6674 : The goal column is stored in the variable `goal-column'.
6675 : This is a buffer-local setting."
6676 : (interactive "P")
6677 0 : (if arg
6678 0 : (progn
6679 0 : (setq goal-column nil)
6680 0 : (message "No goal column"))
6681 0 : (setq goal-column (current-column))
6682 : ;; The older method below can be erroneous if `set-goal-column' is bound
6683 : ;; to a sequence containing %
6684 : ;;(message (substitute-command-keys
6685 : ;;"Goal column %d (use \\[set-goal-column] with an arg to unset it)")
6686 : ;;goal-column)
6687 0 : (message "%s"
6688 0 : (concat
6689 0 : (format "Goal column %d " goal-column)
6690 0 : (substitute-command-keys
6691 0 : "(use \\[set-goal-column] with an arg to unset it)")))
6692 :
6693 0 : )
6694 : nil)
6695 :
6696 : ;;; Editing based on visual lines, as opposed to logical lines.
6697 :
6698 : (defun end-of-visual-line (&optional n)
6699 : "Move point to end of current visual line.
6700 : With argument N not nil or 1, move forward N - 1 visual lines first.
6701 : If point reaches the beginning or end of buffer, it stops there.
6702 : To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6703 : (interactive "^p")
6704 0 : (or n (setq n 1))
6705 0 : (if (/= n 1)
6706 0 : (let ((line-move-visual t))
6707 0 : (line-move (1- n) t)))
6708 : ;; Unlike `move-beginning-of-line', `move-end-of-line' doesn't
6709 : ;; constrain to field boundaries, so we don't either.
6710 0 : (vertical-motion (cons (window-width) 0)))
6711 :
6712 : (defun beginning-of-visual-line (&optional n)
6713 : "Move point to beginning of current visual line.
6714 : With argument N not nil or 1, move forward N - 1 visual lines first.
6715 : If point reaches the beginning or end of buffer, it stops there.
6716 : \(But if the buffer doesn't end in a newline, it stops at the
6717 : beginning of the last visual line.)
6718 : To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
6719 : (interactive "^p")
6720 0 : (or n (setq n 1))
6721 0 : (let ((opoint (point)))
6722 0 : (if (/= n 1)
6723 0 : (let ((line-move-visual t))
6724 0 : (line-move (1- n) t)))
6725 0 : (vertical-motion 0)
6726 : ;; Constrain to field boundaries, like `move-beginning-of-line'.
6727 0 : (goto-char (constrain-to-field (point) opoint (/= n 1)))))
6728 :
6729 : (defun kill-visual-line (&optional arg)
6730 : "Kill the rest of the visual line.
6731 : With prefix argument ARG, kill that many visual lines from point.
6732 : If ARG is negative, kill visual lines backward.
6733 : If ARG is zero, kill the text before point on the current visual
6734 : line.
6735 :
6736 : If you want to append the killed line to the last killed text,
6737 : use \\[append-next-kill] before \\[kill-line].
6738 :
6739 : If the buffer is read-only, Emacs will beep and refrain from deleting
6740 : the line, but put the line in the kill ring anyway. This means that
6741 : you can use this command to copy text from a read-only buffer.
6742 : \(If the variable `kill-read-only-ok' is non-nil, then this won't
6743 : even beep.)"
6744 : (interactive "P")
6745 : ;; Like in `kill-line', it's better to move point to the other end
6746 : ;; of the kill before killing.
6747 0 : (let ((opoint (point))
6748 0 : (kill-whole-line (and kill-whole-line (bolp))))
6749 0 : (if arg
6750 0 : (vertical-motion (prefix-numeric-value arg))
6751 0 : (end-of-visual-line 1)
6752 0 : (if (= (point) opoint)
6753 0 : (vertical-motion 1)
6754 : ;; Skip any trailing whitespace at the end of the visual line.
6755 : ;; We used to do this only if `show-trailing-whitespace' is
6756 : ;; nil, but that's wrong; the correct thing would be to check
6757 : ;; whether the trailing whitespace is highlighted. But, it's
6758 : ;; OK to just do this unconditionally.
6759 0 : (skip-chars-forward " \t")))
6760 0 : (kill-region opoint (if (and kill-whole-line (= (following-char) ?\n))
6761 0 : (1+ (point))
6762 0 : (point)))))
6763 :
6764 : (defun next-logical-line (&optional arg try-vscroll)
6765 : "Move cursor vertically down ARG lines.
6766 : This is identical to `next-line', except that it always moves
6767 : by logical lines instead of visual lines, ignoring the value of
6768 : the variable `line-move-visual'."
6769 : (interactive "^p\np")
6770 0 : (let ((line-move-visual nil))
6771 0 : (with-no-warnings
6772 0 : (next-line arg try-vscroll))))
6773 :
6774 : (defun previous-logical-line (&optional arg try-vscroll)
6775 : "Move cursor vertically up ARG lines.
6776 : This is identical to `previous-line', except that it always moves
6777 : by logical lines instead of visual lines, ignoring the value of
6778 : the variable `line-move-visual'."
6779 : (interactive "^p\np")
6780 0 : (let ((line-move-visual nil))
6781 0 : (with-no-warnings
6782 0 : (previous-line arg try-vscroll))))
6783 :
6784 : (defgroup visual-line nil
6785 : "Editing based on visual lines."
6786 : :group 'convenience
6787 : :version "23.1")
6788 :
6789 : (defvar visual-line-mode-map
6790 : (let ((map (make-sparse-keymap)))
6791 : (define-key map [remap kill-line] 'kill-visual-line)
6792 : (define-key map [remap move-beginning-of-line] 'beginning-of-visual-line)
6793 : (define-key map [remap move-end-of-line] 'end-of-visual-line)
6794 : ;; These keybindings interfere with xterm function keys. Are
6795 : ;; there any other suitable bindings?
6796 : ;; (define-key map "\M-[" 'previous-logical-line)
6797 : ;; (define-key map "\M-]" 'next-logical-line)
6798 : map))
6799 :
6800 : (defcustom visual-line-fringe-indicators '(nil nil)
6801 : "How fringe indicators are shown for wrapped lines in `visual-line-mode'.
6802 : The value should be a list of the form (LEFT RIGHT), where LEFT
6803 : and RIGHT are symbols representing the bitmaps to display, to
6804 : indicate wrapped lines, in the left and right fringes respectively.
6805 : See also `fringe-indicator-alist'.
6806 : The default is not to display fringe indicators for wrapped lines.
6807 : This variable does not affect fringe indicators displayed for
6808 : other purposes."
6809 : :type '(list (choice (const :tag "Hide left indicator" nil)
6810 : (const :tag "Left curly arrow" left-curly-arrow)
6811 : (symbol :tag "Other bitmap"))
6812 : (choice (const :tag "Hide right indicator" nil)
6813 : (const :tag "Right curly arrow" right-curly-arrow)
6814 : (symbol :tag "Other bitmap")))
6815 : :set (lambda (symbol value)
6816 : (dolist (buf (buffer-list))
6817 : (with-current-buffer buf
6818 : (when (and (boundp 'visual-line-mode)
6819 : (symbol-value 'visual-line-mode))
6820 : (setq fringe-indicator-alist
6821 : (cons (cons 'continuation value)
6822 : (assq-delete-all
6823 : 'continuation
6824 : (copy-tree fringe-indicator-alist)))))))
6825 : (set-default symbol value)))
6826 :
6827 : (defvar visual-line--saved-state nil)
6828 :
6829 : (define-minor-mode visual-line-mode
6830 : "Toggle visual line based editing (Visual Line mode).
6831 : With a prefix argument ARG, enable Visual Line mode if ARG is
6832 : positive, and disable it otherwise. If called from Lisp, enable
6833 : the mode if ARG is omitted or nil.
6834 :
6835 : When Visual Line mode is enabled, `word-wrap' is turned on in
6836 : this buffer, and simple editing commands are redefined to act on
6837 : visual lines, not logical lines. See Info node `Visual Line
6838 : Mode' for details."
6839 : :keymap visual-line-mode-map
6840 : :group 'visual-line
6841 : :lighter " Wrap"
6842 0 : (if visual-line-mode
6843 0 : (progn
6844 0 : (set (make-local-variable 'visual-line--saved-state) nil)
6845 : ;; Save the local values of some variables, to be restored if
6846 : ;; visual-line-mode is turned off.
6847 0 : (dolist (var '(line-move-visual truncate-lines
6848 : truncate-partial-width-windows
6849 : word-wrap fringe-indicator-alist))
6850 0 : (if (local-variable-p var)
6851 0 : (push (cons var (symbol-value var))
6852 0 : visual-line--saved-state)))
6853 0 : (set (make-local-variable 'line-move-visual) t)
6854 0 : (set (make-local-variable 'truncate-partial-width-windows) nil)
6855 0 : (setq truncate-lines nil
6856 : word-wrap t
6857 : fringe-indicator-alist
6858 0 : (cons (cons 'continuation visual-line-fringe-indicators)
6859 0 : fringe-indicator-alist)))
6860 0 : (kill-local-variable 'line-move-visual)
6861 0 : (kill-local-variable 'word-wrap)
6862 0 : (kill-local-variable 'truncate-lines)
6863 0 : (kill-local-variable 'truncate-partial-width-windows)
6864 0 : (kill-local-variable 'fringe-indicator-alist)
6865 0 : (dolist (saved visual-line--saved-state)
6866 0 : (set (make-local-variable (car saved)) (cdr saved)))
6867 0 : (kill-local-variable 'visual-line--saved-state)))
6868 :
6869 : (defun turn-on-visual-line-mode ()
6870 0 : (visual-line-mode 1))
6871 :
6872 : (define-globalized-minor-mode global-visual-line-mode
6873 : visual-line-mode turn-on-visual-line-mode)
6874 :
6875 :
6876 : (defun transpose-chars (arg)
6877 : "Interchange characters around point, moving forward one character.
6878 : With prefix arg ARG, effect is to take character before point
6879 : and drag it forward past ARG other characters (backward if ARG negative).
6880 : If no argument and at end of line, the previous two chars are exchanged."
6881 : (interactive "*P")
6882 0 : (when (and (null arg) (eolp) (not (bobp))
6883 0 : (not (get-text-property (1- (point)) 'read-only)))
6884 0 : (forward-char -1))
6885 0 : (transpose-subr 'forward-char (prefix-numeric-value arg)))
6886 :
6887 : (defun transpose-words (arg)
6888 : "Interchange words around point, leaving point at end of them.
6889 : With prefix arg ARG, effect is to take word before or around point
6890 : and drag it forward past ARG other words (backward if ARG negative).
6891 : If ARG is zero, the words around or after point and around or after mark
6892 : are interchanged."
6893 : ;; FIXME: `foo a!nd bar' should transpose into `bar and foo'.
6894 : (interactive "*p")
6895 0 : (transpose-subr 'forward-word arg))
6896 :
6897 : (defun transpose-sexps (arg)
6898 : "Like \\[transpose-chars] (`transpose-chars'), but applies to sexps.
6899 : Unlike `transpose-words', point must be between the two sexps and not
6900 : in the middle of a sexp to be transposed.
6901 : With non-zero prefix arg ARG, effect is to take the sexp before point
6902 : and drag it forward past ARG other sexps (backward if ARG is negative).
6903 : If ARG is zero, the sexps ending at or after point and at or after mark
6904 : are interchanged."
6905 : (interactive "*p")
6906 0 : (transpose-subr
6907 : (lambda (arg)
6908 : ;; Here we should try to simulate the behavior of
6909 : ;; (cons (progn (forward-sexp x) (point))
6910 : ;; (progn (forward-sexp (- x)) (point)))
6911 : ;; Except that we don't want to rely on the second forward-sexp
6912 : ;; putting us back to where we want to be, since forward-sexp-function
6913 : ;; might do funny things like infix-precedence.
6914 0 : (if (if (> arg 0)
6915 0 : (looking-at "\\sw\\|\\s_")
6916 0 : (and (not (bobp))
6917 0 : (save-excursion (forward-char -1) (looking-at "\\sw\\|\\s_"))))
6918 : ;; Jumping over a symbol. We might be inside it, mind you.
6919 0 : (progn (funcall (if (> arg 0)
6920 0 : 'skip-syntax-backward 'skip-syntax-forward)
6921 0 : "w_")
6922 0 : (cons (save-excursion (forward-sexp arg) (point)) (point)))
6923 : ;; Otherwise, we're between sexps. Take a step back before jumping
6924 : ;; to make sure we'll obey the same precedence no matter which direction
6925 : ;; we're going.
6926 0 : (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) " .")
6927 0 : (cons (save-excursion (forward-sexp arg) (point))
6928 0 : (progn (while (or (forward-comment (if (> arg 0) 1 -1))
6929 0 : (not (zerop (funcall (if (> arg 0)
6930 : 'skip-syntax-forward
6931 0 : 'skip-syntax-backward)
6932 0 : ".")))))
6933 0 : (point)))))
6934 0 : arg 'special))
6935 :
6936 : (defun transpose-lines (arg)
6937 : "Exchange current line and previous line, leaving point after both.
6938 : With argument ARG, takes previous line and moves it past ARG lines.
6939 : With argument 0, interchanges line point is in with line mark is in."
6940 : (interactive "*p")
6941 0 : (transpose-subr (function
6942 : (lambda (arg)
6943 0 : (if (> arg 0)
6944 0 : (progn
6945 : ;; Move forward over ARG lines,
6946 : ;; but create newlines if necessary.
6947 0 : (setq arg (forward-line arg))
6948 0 : (if (/= (preceding-char) ?\n)
6949 0 : (setq arg (1+ arg)))
6950 0 : (if (> arg 0)
6951 0 : (newline arg)))
6952 0 : (forward-line arg))))
6953 0 : arg))
6954 :
6955 : ;; FIXME seems to leave point BEFORE the current object when ARG = 0,
6956 : ;; which seems inconsistent with the ARG /= 0 case.
6957 : ;; FIXME document SPECIAL.
6958 : (defun transpose-subr (mover arg &optional special)
6959 : "Subroutine to do the work of transposing objects.
6960 : Works for lines, sentences, paragraphs, etc. MOVER is a function that
6961 : moves forward by units of the given object (e.g. forward-sentence,
6962 : forward-paragraph). If ARG is zero, exchanges the current object
6963 : with the one containing mark. If ARG is an integer, moves the
6964 : current object past ARG following (if ARG is positive) or
6965 : preceding (if ARG is negative) objects, leaving point after the
6966 : current object."
6967 0 : (let ((aux (if special mover
6968 : (lambda (x)
6969 0 : (cons (progn (funcall mover x) (point))
6970 0 : (progn (funcall mover (- x)) (point))))))
6971 : pos1 pos2)
6972 0 : (cond
6973 0 : ((= arg 0)
6974 0 : (save-excursion
6975 0 : (setq pos1 (funcall aux 1))
6976 0 : (goto-char (or (mark) (error "No mark set in this buffer")))
6977 0 : (setq pos2 (funcall aux 1))
6978 0 : (transpose-subr-1 pos1 pos2))
6979 0 : (exchange-point-and-mark))
6980 0 : ((> arg 0)
6981 0 : (setq pos1 (funcall aux -1))
6982 0 : (setq pos2 (funcall aux arg))
6983 0 : (transpose-subr-1 pos1 pos2)
6984 0 : (goto-char (car pos2)))
6985 : (t
6986 0 : (setq pos1 (funcall aux -1))
6987 0 : (goto-char (car pos1))
6988 0 : (setq pos2 (funcall aux arg))
6989 0 : (transpose-subr-1 pos1 pos2)
6990 0 : (goto-char (+ (car pos2) (- (cdr pos1) (car pos1))))))))
6991 :
6992 : (defun transpose-subr-1 (pos1 pos2)
6993 0 : (when (> (car pos1) (cdr pos1)) (setq pos1 (cons (cdr pos1) (car pos1))))
6994 0 : (when (> (car pos2) (cdr pos2)) (setq pos2 (cons (cdr pos2) (car pos2))))
6995 0 : (when (> (car pos1) (car pos2))
6996 0 : (let ((swap pos1))
6997 0 : (setq pos1 pos2 pos2 swap)))
6998 0 : (if (> (cdr pos1) (car pos2)) (error "Don't have two things to transpose"))
6999 0 : (atomic-change-group
7000 : ;; This sequence of insertions attempts to preserve marker
7001 : ;; positions at the start and end of the transposed objects.
7002 0 : (let* ((word (buffer-substring (car pos2) (cdr pos2)))
7003 0 : (len1 (- (cdr pos1) (car pos1)))
7004 0 : (len2 (length word))
7005 0 : (boundary (make-marker)))
7006 0 : (set-marker boundary (car pos2))
7007 0 : (goto-char (cdr pos1))
7008 0 : (insert-before-markers word)
7009 0 : (setq word (delete-and-extract-region (car pos1) (+ (car pos1) len1)))
7010 0 : (goto-char boundary)
7011 0 : (insert word)
7012 0 : (goto-char (+ boundary len1))
7013 0 : (delete-region (point) (+ (point) len2))
7014 0 : (set-marker boundary nil))))
7015 :
7016 : (defun backward-word (&optional arg)
7017 : "Move backward until encountering the beginning of a word.
7018 : With argument ARG, do this that many times.
7019 : If ARG is omitted or nil, move point backward one word.
7020 :
7021 : The word boundaries are normally determined by the buffer's syntax
7022 : table, but `find-word-boundary-function-table', such as set up
7023 : by `subword-mode', can change that. If a Lisp program needs to
7024 : move by words determined strictly by the syntax table, it should
7025 : use `backward-word-strictly' instead."
7026 : (interactive "^p")
7027 0 : (forward-word (- (or arg 1))))
7028 :
7029 : (defun mark-word (&optional arg allow-extend)
7030 : "Set mark ARG words away from point.
7031 : The place mark goes is the same place \\[forward-word] would
7032 : move to with the same argument.
7033 : Interactively, if this command is repeated
7034 : or (in Transient Mark mode) if the mark is active,
7035 : it marks the next ARG words after the ones already marked."
7036 : (interactive "P\np")
7037 0 : (cond ((and allow-extend
7038 0 : (or (and (eq last-command this-command) (mark t))
7039 0 : (region-active-p)))
7040 0 : (setq arg (if arg (prefix-numeric-value arg)
7041 0 : (if (< (mark) (point)) -1 1)))
7042 0 : (set-mark
7043 0 : (save-excursion
7044 0 : (goto-char (mark))
7045 0 : (forward-word arg)
7046 0 : (point))))
7047 : (t
7048 0 : (push-mark
7049 0 : (save-excursion
7050 0 : (forward-word (prefix-numeric-value arg))
7051 0 : (point))
7052 0 : nil t))))
7053 :
7054 : (defun kill-word (arg)
7055 : "Kill characters forward until encountering the end of a word.
7056 : With argument ARG, do this that many times."
7057 : (interactive "p")
7058 0 : (kill-region (point) (progn (forward-word arg) (point))))
7059 :
7060 : (defun backward-kill-word (arg)
7061 : "Kill characters backward until encountering the beginning of a word.
7062 : With argument ARG, do this that many times."
7063 : (interactive "p")
7064 0 : (kill-word (- arg)))
7065 :
7066 : (defun current-word (&optional strict really-word)
7067 : "Return the word at or near point, as a string.
7068 : The return value includes no text properties.
7069 :
7070 : If optional arg STRICT is non-nil, return nil unless point is
7071 : within or adjacent to a word, otherwise look for a word within
7072 : point's line. If there is no word anywhere on point's line, the
7073 : value is nil regardless of STRICT.
7074 :
7075 : By default, this function treats as a single word any sequence of
7076 : characters that have either word or symbol syntax. If optional
7077 : arg REALLY-WORD is non-nil, only characters of word syntax can
7078 : constitute a word."
7079 0 : (save-excursion
7080 0 : (let* ((oldpoint (point)) (start (point)) (end (point))
7081 0 : (syntaxes (if really-word "w" "w_"))
7082 0 : (not-syntaxes (concat "^" syntaxes)))
7083 0 : (skip-syntax-backward syntaxes) (setq start (point))
7084 0 : (goto-char oldpoint)
7085 0 : (skip-syntax-forward syntaxes) (setq end (point))
7086 0 : (when (and (eq start oldpoint) (eq end oldpoint)
7087 : ;; Point is neither within nor adjacent to a word.
7088 0 : (not strict))
7089 : ;; Look for preceding word in same line.
7090 0 : (skip-syntax-backward not-syntaxes (line-beginning-position))
7091 0 : (if (bolp)
7092 : ;; No preceding word in same line.
7093 : ;; Look for following word in same line.
7094 0 : (progn
7095 0 : (skip-syntax-forward not-syntaxes (line-end-position))
7096 0 : (setq start (point))
7097 0 : (skip-syntax-forward syntaxes)
7098 0 : (setq end (point)))
7099 0 : (setq end (point))
7100 0 : (skip-syntax-backward syntaxes)
7101 0 : (setq start (point))))
7102 : ;; If we found something nonempty, return it as a string.
7103 0 : (unless (= start end)
7104 0 : (buffer-substring-no-properties start end)))))
7105 :
7106 : (defcustom fill-prefix nil
7107 : "String for filling to insert at front of new line, or nil for none."
7108 : :type '(choice (const :tag "None" nil)
7109 : string)
7110 : :group 'fill)
7111 : (make-variable-buffer-local 'fill-prefix)
7112 : (put 'fill-prefix 'safe-local-variable 'string-or-null-p)
7113 :
7114 : (defcustom auto-fill-inhibit-regexp nil
7115 : "Regexp to match lines which should not be auto-filled."
7116 : :type '(choice (const :tag "None" nil)
7117 : regexp)
7118 : :group 'fill)
7119 :
7120 : (defun do-auto-fill ()
7121 : "The default value for `normal-auto-fill-function'.
7122 : This is the default auto-fill function, some major modes use a different one.
7123 : Returns t if it really did any work."
7124 0 : (let (fc justify give-up
7125 0 : (fill-prefix fill-prefix))
7126 0 : (if (or (not (setq justify (current-justification)))
7127 0 : (null (setq fc (current-fill-column)))
7128 0 : (and (eq justify 'left)
7129 0 : (<= (current-column) fc))
7130 0 : (and auto-fill-inhibit-regexp
7131 0 : (save-excursion (beginning-of-line)
7132 0 : (looking-at auto-fill-inhibit-regexp))))
7133 : nil ;; Auto-filling not required
7134 0 : (if (memq justify '(full center right))
7135 0 : (save-excursion (unjustify-current-line)))
7136 :
7137 : ;; Choose a fill-prefix automatically.
7138 0 : (when (and adaptive-fill-mode
7139 0 : (or (null fill-prefix) (string= fill-prefix "")))
7140 0 : (let ((prefix
7141 0 : (fill-context-prefix
7142 0 : (save-excursion (fill-forward-paragraph -1) (point))
7143 0 : (save-excursion (fill-forward-paragraph 1) (point)))))
7144 0 : (and prefix (not (equal prefix ""))
7145 : ;; Use auto-indentation rather than a guessed empty prefix.
7146 0 : (not (and fill-indent-according-to-mode
7147 0 : (string-match "\\`[ \t]*\\'" prefix)))
7148 0 : (setq fill-prefix prefix))))
7149 :
7150 0 : (while (and (not give-up) (> (current-column) fc))
7151 : ;; Determine where to split the line.
7152 0 : (let* (after-prefix
7153 : (fill-point
7154 0 : (save-excursion
7155 0 : (beginning-of-line)
7156 0 : (setq after-prefix (point))
7157 0 : (and fill-prefix
7158 0 : (looking-at (regexp-quote fill-prefix))
7159 0 : (setq after-prefix (match-end 0)))
7160 0 : (move-to-column (1+ fc))
7161 0 : (fill-move-to-break-point after-prefix)
7162 0 : (point))))
7163 :
7164 : ;; See whether the place we found is any good.
7165 0 : (if (save-excursion
7166 0 : (goto-char fill-point)
7167 0 : (or (bolp)
7168 : ;; There is no use breaking at end of line.
7169 0 : (save-excursion (skip-chars-forward " ") (eolp))
7170 : ;; It is futile to split at the end of the prefix
7171 : ;; since we would just insert the prefix again.
7172 0 : (and after-prefix (<= (point) after-prefix))
7173 : ;; Don't split right after a comment starter
7174 : ;; since we would just make another comment starter.
7175 0 : (and comment-start-skip
7176 0 : (let ((limit (point)))
7177 0 : (beginning-of-line)
7178 0 : (and (re-search-forward comment-start-skip
7179 0 : limit t)
7180 0 : (eq (point) limit))))))
7181 : ;; No good place to break => stop trying.
7182 0 : (setq give-up t)
7183 : ;; Ok, we have a useful place to break the line. Do it.
7184 0 : (let ((prev-column (current-column)))
7185 : ;; If point is at the fill-point, do not `save-excursion'.
7186 : ;; Otherwise, if a comment prefix or fill-prefix is inserted,
7187 : ;; point will end up before it rather than after it.
7188 0 : (if (save-excursion
7189 0 : (skip-chars-backward " \t")
7190 0 : (= (point) fill-point))
7191 0 : (default-indent-new-line t)
7192 0 : (save-excursion
7193 0 : (goto-char fill-point)
7194 0 : (default-indent-new-line t)))
7195 : ;; Now do justification, if required
7196 0 : (if (not (eq justify 'left))
7197 0 : (save-excursion
7198 0 : (end-of-line 0)
7199 0 : (justify-current-line justify nil t)))
7200 : ;; If making the new line didn't reduce the hpos of
7201 : ;; the end of the line, then give up now;
7202 : ;; trying again will not help.
7203 0 : (if (>= (current-column) prev-column)
7204 0 : (setq give-up t))))))
7205 : ;; Justify last line.
7206 0 : (justify-current-line justify t t)
7207 0 : t)))
7208 :
7209 : (defvar comment-line-break-function 'comment-indent-new-line
7210 : "Mode-specific function which line breaks and continues a comment.
7211 : This function is called during auto-filling when a comment syntax
7212 : is defined.
7213 : The function should take a single optional argument, which is a flag
7214 : indicating whether it should use soft newlines.")
7215 :
7216 : (defun default-indent-new-line (&optional soft)
7217 : "Break line at point and indent.
7218 : If a comment syntax is defined, call `comment-indent-new-line'.
7219 :
7220 : The inserted newline is marked hard if variable `use-hard-newlines' is true,
7221 : unless optional argument SOFT is non-nil."
7222 : (interactive)
7223 0 : (if comment-start
7224 0 : (funcall comment-line-break-function soft)
7225 : ;; Insert the newline before removing empty space so that markers
7226 : ;; get preserved better.
7227 0 : (if soft (insert-and-inherit ?\n) (newline 1))
7228 0 : (save-excursion (forward-char -1) (delete-horizontal-space))
7229 0 : (delete-horizontal-space)
7230 :
7231 0 : (if (and fill-prefix (not adaptive-fill-mode))
7232 : ;; Blindly trust a non-adaptive fill-prefix.
7233 0 : (progn
7234 0 : (indent-to-left-margin)
7235 0 : (insert-before-markers-and-inherit fill-prefix))
7236 :
7237 0 : (cond
7238 : ;; If there's an adaptive prefix, use it unless we're inside
7239 : ;; a comment and the prefix is not a comment starter.
7240 0 : (fill-prefix
7241 0 : (indent-to-left-margin)
7242 0 : (insert-and-inherit fill-prefix))
7243 : ;; If we're not inside a comment, just try to indent.
7244 0 : (t (indent-according-to-mode))))))
7245 :
7246 : (defun internal-auto-fill ()
7247 : "The function called by `self-insert-command' to perform auto-filling."
7248 0 : (when (or (not comment-start)
7249 0 : (not comment-auto-fill-only-comments)
7250 0 : (nth 4 (syntax-ppss)))
7251 0 : (funcall auto-fill-function)))
7252 :
7253 : (defvar normal-auto-fill-function 'do-auto-fill
7254 : "The function to use for `auto-fill-function' if Auto Fill mode is turned on.
7255 : Some major modes set this.")
7256 :
7257 : (put 'auto-fill-function :minor-mode-function 'auto-fill-mode)
7258 : ;; `functions' and `hooks' are usually unsafe to set, but setting
7259 : ;; auto-fill-function to nil in a file-local setting is safe and
7260 : ;; can be useful to prevent auto-filling.
7261 : (put 'auto-fill-function 'safe-local-variable 'null)
7262 :
7263 : (define-minor-mode auto-fill-mode
7264 : "Toggle automatic line breaking (Auto Fill mode).
7265 : With a prefix argument ARG, enable Auto Fill mode if ARG is
7266 : positive, and disable it otherwise. If called from Lisp, enable
7267 : the mode if ARG is omitted or nil.
7268 :
7269 : When Auto Fill mode is enabled, inserting a space at a column
7270 : beyond `current-fill-column' automatically breaks the line at a
7271 : previous space.
7272 :
7273 : When `auto-fill-mode' is on, the `auto-fill-function' variable is
7274 : non-nil.
7275 :
7276 : The value of `normal-auto-fill-function' specifies the function to use
7277 : for `auto-fill-function' when turning Auto Fill mode on."
7278 : :variable (auto-fill-function
7279 : . (lambda (v) (setq auto-fill-function
7280 : (if v normal-auto-fill-function)))))
7281 :
7282 : ;; This holds a document string used to document auto-fill-mode.
7283 : (defun auto-fill-function ()
7284 : "Automatically break line at a previous space, in insertion of text."
7285 : nil)
7286 :
7287 : (defun turn-on-auto-fill ()
7288 : "Unconditionally turn on Auto Fill mode."
7289 0 : (auto-fill-mode 1))
7290 :
7291 : (defun turn-off-auto-fill ()
7292 : "Unconditionally turn off Auto Fill mode."
7293 0 : (auto-fill-mode -1))
7294 :
7295 : (custom-add-option 'text-mode-hook 'turn-on-auto-fill)
7296 :
7297 : (defun set-fill-column (arg)
7298 : "Set `fill-column' to specified argument.
7299 : Use \\[universal-argument] followed by a number to specify a column.
7300 : Just \\[universal-argument] as argument means to use the current column."
7301 : (interactive
7302 0 : (list (or current-prefix-arg
7303 : ;; We used to use current-column silently, but C-x f is too easily
7304 : ;; typed as a typo for C-x C-f, so we turned it into an error and
7305 : ;; now an interactive prompt.
7306 0 : (read-number "Set fill-column to: " (current-column)))))
7307 0 : (if (consp arg)
7308 0 : (setq arg (current-column)))
7309 0 : (if (not (integerp arg))
7310 : ;; Disallow missing argument; it's probably a typo for C-x C-f.
7311 0 : (error "set-fill-column requires an explicit argument")
7312 0 : (message "Fill column set to %d (was %d)" arg fill-column)
7313 0 : (setq fill-column arg)))
7314 :
7315 : (defun set-selective-display (arg)
7316 : "Set `selective-display' to ARG; clear it if no arg.
7317 : When the value of `selective-display' is a number > 0,
7318 : lines whose indentation is >= that value are not displayed.
7319 : The variable `selective-display' has a separate value for each buffer."
7320 : (interactive "P")
7321 0 : (if (eq selective-display t)
7322 0 : (error "selective-display already in use for marked lines"))
7323 0 : (let ((current-vpos
7324 0 : (save-restriction
7325 0 : (narrow-to-region (point-min) (point))
7326 0 : (goto-char (window-start))
7327 0 : (vertical-motion (window-height)))))
7328 0 : (setq selective-display
7329 0 : (and arg (prefix-numeric-value arg)))
7330 0 : (recenter current-vpos))
7331 0 : (set-window-start (selected-window) (window-start))
7332 0 : (princ "selective-display set to " t)
7333 0 : (prin1 selective-display t)
7334 0 : (princ "." t))
7335 :
7336 : (defvaralias 'indicate-unused-lines 'indicate-empty-lines)
7337 :
7338 : (defun toggle-truncate-lines (&optional arg)
7339 : "Toggle truncating of long lines for the current buffer.
7340 : When truncating is off, long lines are folded.
7341 : With prefix argument ARG, truncate long lines if ARG is positive,
7342 : otherwise fold them. Note that in side-by-side windows, this
7343 : command has no effect if `truncate-partial-width-windows' is
7344 : non-nil."
7345 : (interactive "P")
7346 0 : (setq truncate-lines
7347 0 : (if (null arg)
7348 0 : (not truncate-lines)
7349 0 : (> (prefix-numeric-value arg) 0)))
7350 0 : (force-mode-line-update)
7351 0 : (unless truncate-lines
7352 0 : (let ((buffer (current-buffer)))
7353 0 : (walk-windows (lambda (window)
7354 0 : (if (eq buffer (window-buffer window))
7355 0 : (set-window-hscroll window 0)))
7356 0 : nil t)))
7357 0 : (message "Truncate long lines %s"
7358 0 : (if truncate-lines "enabled" "disabled")))
7359 :
7360 : (defun toggle-word-wrap (&optional arg)
7361 : "Toggle whether to use word-wrapping for continuation lines.
7362 : With prefix argument ARG, wrap continuation lines at word boundaries
7363 : if ARG is positive, otherwise wrap them at the right screen edge.
7364 : This command toggles the value of `word-wrap'. It has no effect
7365 : if long lines are truncated."
7366 : (interactive "P")
7367 0 : (setq word-wrap
7368 0 : (if (null arg)
7369 0 : (not word-wrap)
7370 0 : (> (prefix-numeric-value arg) 0)))
7371 0 : (force-mode-line-update)
7372 0 : (message "Word wrapping %s"
7373 0 : (if word-wrap "enabled" "disabled")))
7374 :
7375 : (defvar overwrite-mode-textual (purecopy " Ovwrt")
7376 : "The string displayed in the mode line when in overwrite mode.")
7377 : (defvar overwrite-mode-binary (purecopy " Bin Ovwrt")
7378 : "The string displayed in the mode line when in binary overwrite mode.")
7379 :
7380 : (define-minor-mode overwrite-mode
7381 : "Toggle Overwrite mode.
7382 : With a prefix argument ARG, enable Overwrite mode if ARG is
7383 : positive, and disable it otherwise. If called from Lisp, enable
7384 : the mode if ARG is omitted or nil.
7385 :
7386 : When Overwrite mode is enabled, printing characters typed in
7387 : replace existing text on a one-for-one basis, rather than pushing
7388 : it to the right. At the end of a line, such characters extend
7389 : the line. Before a tab, such characters insert until the tab is
7390 : filled in. \\[quoted-insert] still inserts characters in
7391 : overwrite mode; this is supposed to make it easier to insert
7392 : characters when necessary."
7393 : :variable (overwrite-mode
7394 : . (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-textual)))))
7395 :
7396 : (define-minor-mode binary-overwrite-mode
7397 : "Toggle Binary Overwrite mode.
7398 : With a prefix argument ARG, enable Binary Overwrite mode if ARG
7399 : is positive, and disable it otherwise. If called from Lisp,
7400 : enable the mode if ARG is omitted or nil.
7401 :
7402 : When Binary Overwrite mode is enabled, printing characters typed
7403 : in replace existing text. Newlines are not treated specially, so
7404 : typing at the end of a line joins the line to the next, with the
7405 : typed character between them. Typing before a tab character
7406 : simply replaces the tab with the character typed.
7407 : \\[quoted-insert] replaces the text at the cursor, just as
7408 : ordinary typing characters do.
7409 :
7410 : Note that Binary Overwrite mode is not its own minor mode; it is
7411 : a specialization of overwrite mode, entered by setting the
7412 : `overwrite-mode' variable to `overwrite-mode-binary'."
7413 : :variable (overwrite-mode
7414 : . (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-binary)))))
7415 :
7416 : (define-minor-mode line-number-mode
7417 : "Toggle line number display in the mode line (Line Number mode).
7418 : With a prefix argument ARG, enable Line Number mode if ARG is
7419 : positive, and disable it otherwise. If called from Lisp, enable
7420 : the mode if ARG is omitted or nil.
7421 :
7422 : Line numbers do not appear for very large buffers and buffers
7423 : with very long lines; see variables `line-number-display-limit'
7424 : and `line-number-display-limit-width'."
7425 : :init-value t :global t :group 'mode-line)
7426 :
7427 : (define-minor-mode column-number-mode
7428 : "Toggle column number display in the mode line (Column Number mode).
7429 : With a prefix argument ARG, enable Column Number mode if ARG is
7430 : positive, and disable it otherwise.
7431 :
7432 : If called from Lisp, enable the mode if ARG is omitted or nil."
7433 : :global t :group 'mode-line)
7434 :
7435 : (define-minor-mode size-indication-mode
7436 : "Toggle buffer size display in the mode line (Size Indication mode).
7437 : With a prefix argument ARG, enable Size Indication mode if ARG is
7438 : positive, and disable it otherwise.
7439 :
7440 : If called from Lisp, enable the mode if ARG is omitted or nil."
7441 : :global t :group 'mode-line)
7442 :
7443 : (define-minor-mode auto-save-mode
7444 : "Toggle auto-saving in the current buffer (Auto Save mode).
7445 : With a prefix argument ARG, enable Auto Save mode if ARG is
7446 : positive, and disable it otherwise.
7447 :
7448 : If called from Lisp, enable the mode if ARG is omitted or nil."
7449 : :variable ((and buffer-auto-save-file-name
7450 : ;; If auto-save is off because buffer has shrunk,
7451 : ;; then toggling should turn it on.
7452 : (>= buffer-saved-size 0))
7453 : . (lambda (val)
7454 : (setq buffer-auto-save-file-name
7455 : (cond
7456 : ((null val) nil)
7457 : ((and buffer-file-name auto-save-visited-file-name
7458 : (not buffer-read-only))
7459 : buffer-file-name)
7460 : (t (make-auto-save-file-name))))))
7461 : ;; If -1 was stored here, to temporarily turn off saving,
7462 : ;; turn it back on.
7463 0 : (and (< buffer-saved-size 0)
7464 0 : (setq buffer-saved-size 0)))
7465 :
7466 : (defgroup paren-blinking nil
7467 : "Blinking matching of parens and expressions."
7468 : :prefix "blink-matching-"
7469 : :group 'paren-matching)
7470 :
7471 : (defcustom blink-matching-paren t
7472 : "Non-nil means show matching open-paren when close-paren is inserted.
7473 : If t, highlight the paren. If `jump', briefly move cursor to its
7474 : position. If `jump-offscreen', move cursor there even if the
7475 : position is off screen. With any other non-nil value, the
7476 : off-screen position of the opening paren will be shown in the
7477 : echo area."
7478 : :type '(choice
7479 : (const :tag "Disable" nil)
7480 : (const :tag "Highlight" t)
7481 : (const :tag "Move cursor" jump)
7482 : (const :tag "Move cursor, even if off screen" jump-offscreen))
7483 : :group 'paren-blinking)
7484 :
7485 : (defcustom blink-matching-paren-on-screen t
7486 : "Non-nil means show matching open-paren when it is on screen.
7487 : If nil, don't show it (but the open-paren can still be shown
7488 : in the echo area when it is off screen).
7489 :
7490 : This variable has no effect if `blink-matching-paren' is nil.
7491 : \(In that case, the open-paren is never shown.)
7492 : It is also ignored if `show-paren-mode' is enabled."
7493 : :type 'boolean
7494 : :group 'paren-blinking)
7495 :
7496 : (defcustom blink-matching-paren-distance (* 100 1024)
7497 : "If non-nil, maximum distance to search backwards for matching open-paren.
7498 : If nil, search stops at the beginning of the accessible portion of the buffer."
7499 : :version "23.2" ; 25->100k
7500 : :type '(choice (const nil) integer)
7501 : :group 'paren-blinking)
7502 :
7503 : (defcustom blink-matching-delay 1
7504 : "Time in seconds to delay after showing a matching paren."
7505 : :type 'number
7506 : :group 'paren-blinking)
7507 :
7508 : (defcustom blink-matching-paren-dont-ignore-comments nil
7509 : "If nil, `blink-matching-paren' ignores comments.
7510 : More precisely, when looking for the matching parenthesis,
7511 : it skips the contents of comments that end before point."
7512 : :type 'boolean
7513 : :group 'paren-blinking)
7514 :
7515 : (defun blink-matching-check-mismatch (start end)
7516 : "Return whether or not START...END are matching parens.
7517 : END is the current point and START is the blink position.
7518 : START might be nil if no matching starter was found.
7519 : Returns non-nil if we find there is a mismatch."
7520 0 : (let* ((end-syntax (syntax-after (1- end)))
7521 0 : (matching-paren (and (consp end-syntax)
7522 0 : (eq (syntax-class end-syntax) 5)
7523 0 : (cdr end-syntax))))
7524 : ;; For self-matched chars like " and $, we can't know when they're
7525 : ;; mismatched or unmatched, so we can only do it for parens.
7526 0 : (when matching-paren
7527 0 : (not (and start
7528 0 : (or
7529 0 : (eq (char-after start) matching-paren)
7530 : ;; The cdr might hold a new paren-class info rather than
7531 : ;; a matching-char info, in which case the two CDRs
7532 : ;; should match.
7533 0 : (eq matching-paren (cdr-safe (syntax-after start)))))))))
7534 :
7535 : (defvar blink-matching-check-function #'blink-matching-check-mismatch
7536 : "Function to check parentheses mismatches.
7537 : The function takes two arguments (START and END) where START is the
7538 : position just before the opening token and END is the position right after.
7539 : START can be nil, if it was not found.
7540 : The function should return non-nil if the two tokens do not match.")
7541 :
7542 : (defvar blink-matching--overlay
7543 : (let ((ol (make-overlay (point) (point) nil t)))
7544 : (overlay-put ol 'face 'show-paren-match)
7545 : (delete-overlay ol)
7546 : ol)
7547 : "Overlay used to highlight the matching paren.")
7548 :
7549 : (defun blink-matching-open ()
7550 : "Momentarily highlight the beginning of the sexp before point."
7551 : (interactive)
7552 0 : (when (and (not (bobp))
7553 0 : blink-matching-paren)
7554 0 : (let* ((oldpos (point))
7555 : (message-log-max nil) ; Don't log messages about paren matching.
7556 : (blinkpos
7557 0 : (save-excursion
7558 0 : (save-restriction
7559 0 : (if blink-matching-paren-distance
7560 0 : (narrow-to-region
7561 0 : (max (minibuffer-prompt-end) ;(point-min) unless minibuf.
7562 0 : (- (point) blink-matching-paren-distance))
7563 0 : oldpos))
7564 0 : (let ((parse-sexp-ignore-comments
7565 0 : (and parse-sexp-ignore-comments
7566 0 : (not blink-matching-paren-dont-ignore-comments))))
7567 0 : (condition-case ()
7568 0 : (progn
7569 0 : (syntax-propertize (point))
7570 0 : (forward-sexp -1)
7571 : ;; backward-sexp skips backward over prefix chars,
7572 : ;; so move back to the matching paren.
7573 0 : (while (and (< (point) (1- oldpos))
7574 0 : (let ((code (syntax-after (point))))
7575 0 : (or (eq (syntax-class code) 6)
7576 0 : (eq (logand 1048576 (car code))
7577 0 : 1048576))))
7578 0 : (forward-char 1))
7579 0 : (point))
7580 0 : (error nil))))))
7581 0 : (mismatch (funcall blink-matching-check-function blinkpos oldpos)))
7582 0 : (cond
7583 0 : (mismatch
7584 0 : (if blinkpos
7585 0 : (if (minibufferp)
7586 0 : (minibuffer-message "Mismatched parentheses")
7587 0 : (message "Mismatched parentheses"))
7588 0 : (if (minibufferp)
7589 0 : (minibuffer-message "No matching parenthesis found")
7590 0 : (message "No matching parenthesis found"))))
7591 0 : ((not blinkpos) nil)
7592 0 : ((or
7593 0 : (eq blink-matching-paren 'jump-offscreen)
7594 0 : (pos-visible-in-window-p blinkpos))
7595 : ;; Matching open within window, temporarily move to or highlight
7596 : ;; char after blinkpos but only if `blink-matching-paren-on-screen'
7597 : ;; is non-nil.
7598 0 : (and blink-matching-paren-on-screen
7599 0 : (not show-paren-mode)
7600 0 : (if (memq blink-matching-paren '(jump jump-offscreen))
7601 0 : (save-excursion
7602 0 : (goto-char blinkpos)
7603 0 : (sit-for blink-matching-delay))
7604 0 : (unwind-protect
7605 0 : (progn
7606 0 : (move-overlay blink-matching--overlay blinkpos (1+ blinkpos)
7607 0 : (current-buffer))
7608 0 : (sit-for blink-matching-delay))
7609 0 : (delete-overlay blink-matching--overlay)))))
7610 : (t
7611 0 : (let ((open-paren-line-string
7612 0 : (save-excursion
7613 0 : (goto-char blinkpos)
7614 : ;; Show what precedes the open in its line, if anything.
7615 0 : (cond
7616 0 : ((save-excursion (skip-chars-backward " \t") (not (bolp)))
7617 0 : (buffer-substring (line-beginning-position)
7618 0 : (1+ blinkpos)))
7619 : ;; Show what follows the open in its line, if anything.
7620 0 : ((save-excursion
7621 0 : (forward-char 1)
7622 0 : (skip-chars-forward " \t")
7623 0 : (not (eolp)))
7624 0 : (buffer-substring blinkpos
7625 0 : (line-end-position)))
7626 : ;; Otherwise show the previous nonblank line,
7627 : ;; if there is one.
7628 0 : ((save-excursion (skip-chars-backward "\n \t") (not (bobp)))
7629 0 : (concat
7630 0 : (buffer-substring (progn
7631 0 : (skip-chars-backward "\n \t")
7632 0 : (line-beginning-position))
7633 0 : (progn (end-of-line)
7634 0 : (skip-chars-backward " \t")
7635 0 : (point)))
7636 : ;; Replace the newline and other whitespace with `...'.
7637 : "..."
7638 0 : (buffer-substring blinkpos (1+ blinkpos))))
7639 : ;; There is nothing to show except the char itself.
7640 0 : (t (buffer-substring blinkpos (1+ blinkpos)))))))
7641 0 : (minibuffer-message
7642 : "Matches %s"
7643 0 : (substring-no-properties open-paren-line-string))))))))
7644 :
7645 : (defvar blink-paren-function 'blink-matching-open
7646 : "Function called, if non-nil, whenever a close parenthesis is inserted.
7647 : More precisely, a char with closeparen syntax is self-inserted.")
7648 :
7649 : (defun blink-paren-post-self-insert-function ()
7650 0 : (when (and (eq (char-before) last-command-event) ; Sanity check.
7651 0 : (memq (char-syntax last-command-event) '(?\) ?\$))
7652 0 : blink-paren-function
7653 0 : (not executing-kbd-macro)
7654 0 : (not noninteractive)
7655 : ;; Verify an even number of quoting characters precede the close.
7656 : ;; FIXME: Also check if this parenthesis closes a comment as
7657 : ;; can happen in Pascal and SML.
7658 0 : (= 1 (logand 1 (- (point)
7659 0 : (save-excursion
7660 0 : (forward-char -1)
7661 0 : (skip-syntax-backward "/\\")
7662 0 : (point))))))
7663 0 : (funcall blink-paren-function)))
7664 :
7665 : (put 'blink-paren-post-self-insert-function 'priority 100)
7666 :
7667 : (add-hook 'post-self-insert-hook #'blink-paren-post-self-insert-function
7668 : ;; Most likely, this hook is nil, so this arg doesn't matter,
7669 : ;; but I use it as a reminder that this function usually
7670 : ;; likes to be run after others since it does
7671 : ;; `sit-for'. That's also the reason it get a `priority' prop
7672 : ;; of 100.
7673 : 'append)
7674 :
7675 : ;; This executes C-g typed while Emacs is waiting for a command.
7676 : ;; Quitting out of a program does not go through here;
7677 : ;; that happens in the maybe_quit function at the C code level.
7678 : (defun keyboard-quit ()
7679 : "Signal a `quit' condition.
7680 : During execution of Lisp code, this character causes a quit directly.
7681 : At top-level, as an editor command, this simply beeps."
7682 : (interactive)
7683 : ;; Avoid adding the region to the window selection.
7684 0 : (setq saved-region-selection nil)
7685 0 : (let (select-active-regions)
7686 0 : (deactivate-mark))
7687 0 : (if (fboundp 'kmacro-keyboard-quit)
7688 0 : (kmacro-keyboard-quit))
7689 0 : (when completion-in-region-mode
7690 0 : (completion-in-region-mode -1))
7691 : ;; Force the next redisplay cycle to remove the "Def" indicator from
7692 : ;; all the mode lines.
7693 0 : (if defining-kbd-macro
7694 0 : (force-mode-line-update t))
7695 0 : (setq defining-kbd-macro nil)
7696 0 : (let ((debug-on-quit nil))
7697 0 : (signal 'quit nil)))
7698 :
7699 : (defvar buffer-quit-function nil
7700 : "Function to call to \"quit\" the current buffer, or nil if none.
7701 : \\[keyboard-escape-quit] calls this function when its more local actions
7702 : \(such as canceling a prefix argument, minibuffer or region) do not apply.")
7703 :
7704 : (defun keyboard-escape-quit ()
7705 : "Exit the current \"mode\" (in a generalized sense of the word).
7706 : This command can exit an interactive command such as `query-replace',
7707 : can clear out a prefix argument or a region,
7708 : can get out of the minibuffer or other recursive edit,
7709 : cancel the use of the current buffer (for special-purpose buffers),
7710 : or go back to just one window (by deleting all but the selected window)."
7711 : (interactive)
7712 0 : (cond ((eq last-command 'mode-exited) nil)
7713 0 : ((region-active-p)
7714 0 : (deactivate-mark))
7715 0 : ((> (minibuffer-depth) 0)
7716 0 : (abort-recursive-edit))
7717 0 : (current-prefix-arg
7718 : nil)
7719 0 : ((> (recursion-depth) 0)
7720 0 : (exit-recursive-edit))
7721 0 : (buffer-quit-function
7722 0 : (funcall buffer-quit-function))
7723 0 : ((not (one-window-p t))
7724 0 : (delete-other-windows))
7725 0 : ((string-match "^ \\*" (buffer-name (current-buffer)))
7726 0 : (bury-buffer))))
7727 :
7728 : (defun play-sound-file (file &optional volume device)
7729 : "Play sound stored in FILE.
7730 : VOLUME and DEVICE correspond to the keywords of the sound
7731 : specification for `play-sound'."
7732 : (interactive "fPlay sound file: ")
7733 0 : (let ((sound (list :file file)))
7734 0 : (if volume
7735 0 : (plist-put sound :volume volume))
7736 0 : (if device
7737 0 : (plist-put sound :device device))
7738 0 : (push 'sound sound)
7739 0 : (play-sound sound)))
7740 :
7741 :
7742 : (defcustom read-mail-command 'rmail
7743 : "Your preference for a mail reading package.
7744 : This is used by some keybindings which support reading mail.
7745 : See also `mail-user-agent' concerning sending mail."
7746 : :type '(radio (function-item :tag "Rmail" :format "%t\n" rmail)
7747 : (function-item :tag "Gnus" :format "%t\n" gnus)
7748 : (function-item :tag "Emacs interface to MH"
7749 : :format "%t\n" mh-rmail)
7750 : (function :tag "Other"))
7751 : :version "21.1"
7752 : :group 'mail)
7753 :
7754 : (defcustom mail-user-agent 'message-user-agent
7755 : "Your preference for a mail composition package.
7756 : Various Emacs Lisp packages (e.g. Reporter) require you to compose an
7757 : outgoing email message. This variable lets you specify which
7758 : mail-sending package you prefer.
7759 :
7760 : Valid values include:
7761 :
7762 : `message-user-agent' -- use the Message package.
7763 : See Info node `(message)'.
7764 : `sendmail-user-agent' -- use the Mail package.
7765 : See Info node `(emacs)Sending Mail'.
7766 : `mh-e-user-agent' -- use the Emacs interface to the MH mail system.
7767 : See Info node `(mh-e)'.
7768 : `gnus-user-agent' -- like `message-user-agent', but with Gnus
7769 : paraphernalia if Gnus is running, particularly
7770 : the Gcc: header for archiving.
7771 :
7772 : Additional valid symbols may be available; check with the author of
7773 : your package for details. The function should return non-nil if it
7774 : succeeds.
7775 :
7776 : See also `read-mail-command' concerning reading mail."
7777 : :type '(radio (function-item :tag "Message package"
7778 : :format "%t\n"
7779 : message-user-agent)
7780 : (function-item :tag "Mail package"
7781 : :format "%t\n"
7782 : sendmail-user-agent)
7783 : (function-item :tag "Emacs interface to MH"
7784 : :format "%t\n"
7785 : mh-e-user-agent)
7786 : (function-item :tag "Message with full Gnus features"
7787 : :format "%t\n"
7788 : gnus-user-agent)
7789 : (function :tag "Other"))
7790 : :version "23.2" ; sendmail->message
7791 : :group 'mail)
7792 :
7793 : (defcustom compose-mail-user-agent-warnings t
7794 : "If non-nil, `compose-mail' warns about changes in `mail-user-agent'.
7795 : If the value of `mail-user-agent' is the default, and the user
7796 : appears to have customizations applying to the old default,
7797 : `compose-mail' issues a warning."
7798 : :type 'boolean
7799 : :version "23.2"
7800 : :group 'mail)
7801 :
7802 : (defun rfc822-goto-eoh ()
7803 : "If the buffer starts with a mail header, move point to the header's end.
7804 : Otherwise, moves to `point-min'.
7805 : The end of the header is the start of the next line, if there is one,
7806 : else the end of the last line. This function obeys RFC822."
7807 0 : (goto-char (point-min))
7808 0 : (when (re-search-forward
7809 0 : "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move)
7810 0 : (goto-char (match-beginning 0))))
7811 :
7812 : ;; Used by Rmail (e.g., rmail-forward).
7813 : (defvar mail-encode-mml nil
7814 : "If non-nil, mail-user-agent's `sendfunc' command should mml-encode
7815 : the outgoing message before sending it.")
7816 :
7817 : (defun compose-mail (&optional to subject other-headers continue
7818 : switch-function yank-action send-actions
7819 : return-action)
7820 : "Start composing a mail message to send.
7821 : This uses the user's chosen mail composition package
7822 : as selected with the variable `mail-user-agent'.
7823 : The optional arguments TO and SUBJECT specify recipients
7824 : and the initial Subject field, respectively.
7825 :
7826 : OTHER-HEADERS is an alist specifying additional
7827 : header fields. Elements look like (HEADER . VALUE) where both
7828 : HEADER and VALUE are strings.
7829 :
7830 : CONTINUE, if non-nil, says to continue editing a message already
7831 : being composed. Interactively, CONTINUE is the prefix argument.
7832 :
7833 : SWITCH-FUNCTION, if non-nil, is a function to use to
7834 : switch to and display the buffer used for mail composition.
7835 :
7836 : YANK-ACTION, if non-nil, is an action to perform, if and when necessary,
7837 : to insert the raw text of the message being replied to.
7838 : It has the form (FUNCTION . ARGS). The user agent will apply
7839 : FUNCTION to ARGS, to insert the raw text of the original message.
7840 : \(The user agent will also run `mail-citation-hook', *after* the
7841 : original text has been inserted in this way.)
7842 :
7843 : SEND-ACTIONS is a list of actions to call when the message is sent.
7844 : Each action has the form (FUNCTION . ARGS).
7845 :
7846 : RETURN-ACTION, if non-nil, is an action for returning to the
7847 : caller. It has the form (FUNCTION . ARGS). The function is
7848 : called after the mail has been sent or put aside, and the mail
7849 : buffer buried."
7850 : (interactive
7851 0 : (list nil nil nil current-prefix-arg))
7852 :
7853 : ;; In Emacs 23.2, the default value of `mail-user-agent' changed
7854 : ;; from sendmail-user-agent to message-user-agent. Some users may
7855 : ;; encounter incompatibilities. This hack tries to detect problems
7856 : ;; and warn about them.
7857 0 : (and compose-mail-user-agent-warnings
7858 0 : (eq mail-user-agent 'message-user-agent)
7859 0 : (let (warn-vars)
7860 0 : (dolist (var '(mail-mode-hook mail-send-hook mail-setup-hook
7861 : mail-yank-hooks mail-archive-file-name
7862 : mail-default-reply-to mail-mailing-lists
7863 : mail-self-blind))
7864 0 : (and (boundp var)
7865 0 : (symbol-value var)
7866 0 : (push var warn-vars)))
7867 0 : (when warn-vars
7868 0 : (display-warning 'mail
7869 0 : (format-message "\
7870 : The default mail mode is now Message mode.
7871 : You have the following Mail mode variable%s customized:
7872 : \n %s\n\nTo use Mail mode, set `mail-user-agent' to sendmail-user-agent.
7873 : To disable this warning, set `compose-mail-user-agent-warnings' to nil."
7874 0 : (if (> (length warn-vars) 1) "s" "")
7875 0 : (mapconcat 'symbol-name
7876 0 : warn-vars " "))))))
7877 :
7878 0 : (let ((function (get mail-user-agent 'composefunc)))
7879 0 : (funcall function to subject other-headers continue switch-function
7880 0 : yank-action send-actions return-action)))
7881 :
7882 : (defun compose-mail-other-window (&optional to subject other-headers continue
7883 : yank-action send-actions
7884 : return-action)
7885 : "Like \\[compose-mail], but edit the outgoing message in another window."
7886 0 : (interactive (list nil nil nil current-prefix-arg))
7887 0 : (compose-mail to subject other-headers continue
7888 0 : 'switch-to-buffer-other-window yank-action send-actions
7889 0 : return-action))
7890 :
7891 : (defun compose-mail-other-frame (&optional to subject other-headers continue
7892 : yank-action send-actions
7893 : return-action)
7894 : "Like \\[compose-mail], but edit the outgoing message in another frame."
7895 0 : (interactive (list nil nil nil current-prefix-arg))
7896 0 : (compose-mail to subject other-headers continue
7897 0 : 'switch-to-buffer-other-frame yank-action send-actions
7898 0 : return-action))
7899 :
7900 :
7901 : (defvar set-variable-value-history nil
7902 : "History of values entered with `set-variable'.
7903 :
7904 : Maximum length of the history list is determined by the value
7905 : of `history-length', which see.")
7906 :
7907 : (defun set-variable (variable value &optional make-local)
7908 : "Set VARIABLE to VALUE. VALUE is a Lisp object.
7909 : VARIABLE should be a user option variable name, a Lisp variable
7910 : meant to be customized by users. You should enter VALUE in Lisp syntax,
7911 : so if you want VALUE to be a string, you must surround it with doublequotes.
7912 : VALUE is used literally, not evaluated.
7913 :
7914 : If VARIABLE has a `variable-interactive' property, that is used as if
7915 : it were the arg to `interactive' (which see) to interactively read VALUE.
7916 :
7917 : If VARIABLE has been defined with `defcustom', then the type information
7918 : in the definition is used to check that VALUE is valid.
7919 :
7920 : Note that this function is at heart equivalent to the basic `set' function.
7921 : For a variable defined with `defcustom', it does not pay attention to
7922 : any :set property that the variable might have (if you want that, use
7923 : \\[customize-set-variable] instead).
7924 :
7925 : With a prefix argument, set VARIABLE to VALUE buffer-locally."
7926 : (interactive
7927 0 : (let* ((default-var (variable-at-point))
7928 0 : (var (if (custom-variable-p default-var)
7929 0 : (read-variable (format "Set variable (default %s): " default-var)
7930 0 : default-var)
7931 0 : (read-variable "Set variable: ")))
7932 : (minibuffer-help-form '(describe-variable var))
7933 0 : (prop (get var 'variable-interactive))
7934 0 : (obsolete (car (get var 'byte-obsolete-variable)))
7935 0 : (prompt (format "Set %s %s to value: " var
7936 0 : (cond ((local-variable-p var)
7937 : "(buffer-local)")
7938 0 : ((or current-prefix-arg
7939 0 : (local-variable-if-set-p var))
7940 : "buffer-locally")
7941 0 : (t "globally"))))
7942 0 : (val (progn
7943 0 : (when obsolete
7944 0 : (message (concat "`%S' is obsolete; "
7945 0 : (if (symbolp obsolete) "use `%S' instead" "%s"))
7946 0 : var obsolete)
7947 0 : (sit-for 3))
7948 0 : (if prop
7949 : ;; Use VAR's `variable-interactive' property
7950 : ;; as an interactive spec for prompting.
7951 0 : (call-interactively `(lambda (arg)
7952 0 : (interactive ,prop)
7953 0 : arg))
7954 0 : (read-from-minibuffer prompt nil
7955 0 : read-expression-map t
7956 : 'set-variable-value-history
7957 0 : (format "%S" (symbol-value var)))))))
7958 0 : (list var val current-prefix-arg)))
7959 :
7960 0 : (and (custom-variable-p variable)
7961 0 : (not (get variable 'custom-type))
7962 0 : (custom-load-symbol variable))
7963 0 : (let ((type (get variable 'custom-type)))
7964 0 : (when type
7965 : ;; Match with custom type.
7966 0 : (require 'cus-edit)
7967 0 : (setq type (widget-convert type))
7968 0 : (unless (widget-apply type :match value)
7969 0 : (user-error "Value `%S' does not match type %S of %S"
7970 0 : value (car type) variable))))
7971 :
7972 0 : (if make-local
7973 0 : (make-local-variable variable))
7974 :
7975 0 : (set variable value)
7976 :
7977 : ;; Force a thorough redisplay for the case that the variable
7978 : ;; has an effect on the display, like `tab-width' has.
7979 0 : (force-mode-line-update))
7980 :
7981 : ;; Define the major mode for lists of completions.
7982 :
7983 : (defvar completion-list-mode-map
7984 : (let ((map (make-sparse-keymap)))
7985 : (define-key map [mouse-2] 'choose-completion)
7986 : (define-key map [follow-link] 'mouse-face)
7987 : (define-key map [down-mouse-2] nil)
7988 : (define-key map "\C-m" 'choose-completion)
7989 : (define-key map "\e\e\e" 'delete-completion-window)
7990 : (define-key map [left] 'previous-completion)
7991 : (define-key map [right] 'next-completion)
7992 : (define-key map [?\t] 'next-completion)
7993 : (define-key map [backtab] 'previous-completion)
7994 : (define-key map "q" 'quit-window)
7995 : (define-key map "z" 'kill-current-buffer)
7996 : map)
7997 : "Local map for completion list buffers.")
7998 :
7999 : ;; Completion mode is suitable only for specially formatted data.
8000 : (put 'completion-list-mode 'mode-class 'special)
8001 :
8002 : (defvar completion-reference-buffer nil
8003 : "Record the buffer that was current when the completion list was requested.
8004 : This is a local variable in the completion list buffer.
8005 : Initial value is nil to avoid some compiler warnings.")
8006 :
8007 : (defvar completion-no-auto-exit nil
8008 : "Non-nil means `choose-completion-string' should never exit the minibuffer.
8009 : This also applies to other functions such as `choose-completion'.")
8010 :
8011 : (defvar completion-base-position nil
8012 : "Position of the base of the text corresponding to the shown completions.
8013 : This variable is used in the *Completions* buffers.
8014 : Its value is a list of the form (START END) where START is the place
8015 : where the completion should be inserted and END (if non-nil) is the end
8016 : of the text to replace. If END is nil, point is used instead.")
8017 :
8018 : (defvar completion-list-insert-choice-function #'completion--replace
8019 : "Function to use to insert the text chosen in *Completions*.
8020 : Called with three arguments (BEG END TEXT), it should replace the text
8021 : between BEG and END with TEXT. Expected to be set buffer-locally
8022 : in the *Completions* buffer.")
8023 :
8024 : (defvar completion-base-size nil
8025 : "Number of chars before point not involved in completion.
8026 : This is a local variable in the completion list buffer.
8027 : It refers to the chars in the minibuffer if completing in the
8028 : minibuffer, or in `completion-reference-buffer' otherwise.
8029 : Only characters in the field at point are included.
8030 :
8031 : If nil, Emacs determines which part of the tail end of the
8032 : buffer's text is involved in completion by comparing the text
8033 : directly.")
8034 : (make-obsolete-variable 'completion-base-size 'completion-base-position "23.2")
8035 :
8036 : (defun delete-completion-window ()
8037 : "Delete the completion list window.
8038 : Go to the window from which completion was requested."
8039 : (interactive)
8040 0 : (let ((buf completion-reference-buffer))
8041 0 : (if (one-window-p t)
8042 0 : (if (window-dedicated-p) (delete-frame))
8043 0 : (delete-window (selected-window))
8044 0 : (if (get-buffer-window buf)
8045 0 : (select-window (get-buffer-window buf))))))
8046 :
8047 : (defun previous-completion (n)
8048 : "Move to the previous item in the completion list."
8049 : (interactive "p")
8050 0 : (next-completion (- n)))
8051 :
8052 : (defun next-completion (n)
8053 : "Move to the next item in the completion list.
8054 : With prefix argument N, move N items (negative N means move backward)."
8055 : (interactive "p")
8056 0 : (let ((beg (point-min)) (end (point-max)))
8057 0 : (while (and (> n 0) (not (eobp)))
8058 : ;; If in a completion, move to the end of it.
8059 0 : (when (get-text-property (point) 'mouse-face)
8060 0 : (goto-char (next-single-property-change (point) 'mouse-face nil end)))
8061 : ;; Move to start of next one.
8062 0 : (unless (get-text-property (point) 'mouse-face)
8063 0 : (goto-char (next-single-property-change (point) 'mouse-face nil end)))
8064 0 : (setq n (1- n)))
8065 0 : (while (and (< n 0) (not (bobp)))
8066 0 : (let ((prop (get-text-property (1- (point)) 'mouse-face)))
8067 : ;; If in a completion, move to the start of it.
8068 0 : (when (and prop (eq prop (get-text-property (point) 'mouse-face)))
8069 0 : (goto-char (previous-single-property-change
8070 0 : (point) 'mouse-face nil beg)))
8071 : ;; Move to end of the previous completion.
8072 0 : (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face))
8073 0 : (goto-char (previous-single-property-change
8074 0 : (point) 'mouse-face nil beg)))
8075 : ;; Move to the start of that one.
8076 0 : (goto-char (previous-single-property-change
8077 0 : (point) 'mouse-face nil beg))
8078 0 : (setq n (1+ n))))))
8079 :
8080 : (defun choose-completion (&optional event)
8081 : "Choose the completion at point.
8082 : If EVENT, use EVENT's position to determine the starting position."
8083 0 : (interactive (list last-nonmenu-event))
8084 : ;; In case this is run via the mouse, give temporary modes such as
8085 : ;; isearch a chance to turn off.
8086 0 : (run-hooks 'mouse-leave-buffer-hook)
8087 0 : (with-current-buffer (window-buffer (posn-window (event-start event)))
8088 0 : (let ((buffer completion-reference-buffer)
8089 0 : (base-size completion-base-size)
8090 0 : (base-position completion-base-position)
8091 0 : (insert-function completion-list-insert-choice-function)
8092 : (choice
8093 0 : (save-excursion
8094 0 : (goto-char (posn-point (event-start event)))
8095 0 : (let (beg end)
8096 0 : (cond
8097 0 : ((and (not (eobp)) (get-text-property (point) 'mouse-face))
8098 0 : (setq end (point) beg (1+ (point))))
8099 0 : ((and (not (bobp))
8100 0 : (get-text-property (1- (point)) 'mouse-face))
8101 0 : (setq end (1- (point)) beg (point)))
8102 0 : (t (error "No completion here")))
8103 0 : (setq beg (previous-single-property-change beg 'mouse-face))
8104 0 : (setq end (or (next-single-property-change end 'mouse-face)
8105 0 : (point-max)))
8106 0 : (buffer-substring-no-properties beg end)))))
8107 :
8108 0 : (unless (buffer-live-p buffer)
8109 0 : (error "Destination buffer is dead"))
8110 0 : (quit-window nil (posn-window (event-start event)))
8111 :
8112 0 : (with-current-buffer buffer
8113 0 : (choose-completion-string
8114 0 : choice buffer
8115 0 : (or base-position
8116 0 : (when base-size
8117 : ;; Someone's using old completion code that doesn't know
8118 : ;; about base-position yet.
8119 0 : (list (+ base-size (field-beginning))))
8120 : ;; If all else fails, just guess.
8121 0 : (list (choose-completion-guess-base-position choice)))
8122 0 : insert-function)))))
8123 :
8124 : ;; Delete the longest partial match for STRING
8125 : ;; that can be found before POINT.
8126 : (defun choose-completion-guess-base-position (string)
8127 0 : (save-excursion
8128 0 : (let ((opoint (point))
8129 : len)
8130 : ;; Try moving back by the length of the string.
8131 0 : (goto-char (max (- (point) (length string))
8132 0 : (minibuffer-prompt-end)))
8133 : ;; See how far back we were actually able to move. That is the
8134 : ;; upper bound on how much we can match and delete.
8135 0 : (setq len (- opoint (point)))
8136 0 : (if completion-ignore-case
8137 0 : (setq string (downcase string)))
8138 0 : (while (and (> len 0)
8139 0 : (let ((tail (buffer-substring (point) opoint)))
8140 0 : (if completion-ignore-case
8141 0 : (setq tail (downcase tail)))
8142 0 : (not (string= tail (substring string 0 len)))))
8143 0 : (setq len (1- len))
8144 0 : (forward-char 1))
8145 0 : (point))))
8146 :
8147 : (defun choose-completion-delete-max-match (string)
8148 : (declare (obsolete choose-completion-guess-base-position "23.2"))
8149 0 : (delete-region (choose-completion-guess-base-position string) (point)))
8150 :
8151 : (defvar choose-completion-string-functions nil
8152 : "Functions that may override the normal insertion of a completion choice.
8153 : These functions are called in order with three arguments:
8154 : CHOICE - the string to insert in the buffer,
8155 : BUFFER - the buffer in which the choice should be inserted,
8156 : BASE-POSITION - where to insert the completion.
8157 :
8158 : If a function in the list returns non-nil, that function is supposed
8159 : to have inserted the CHOICE in the BUFFER, and possibly exited
8160 : the minibuffer; no further functions will be called.
8161 :
8162 : If all functions in the list return nil, that means to use
8163 : the default method of inserting the completion in BUFFER.")
8164 :
8165 : (defun choose-completion-string (choice &optional
8166 : buffer base-position insert-function)
8167 : "Switch to BUFFER and insert the completion choice CHOICE.
8168 : BASE-POSITION says where to insert the completion.
8169 : INSERT-FUNCTION says how to insert the completion and falls
8170 : back on `completion-list-insert-choice-function' when nil."
8171 :
8172 : ;; If BUFFER is the minibuffer, exit the minibuffer
8173 : ;; unless it is reading a file name and CHOICE is a directory,
8174 : ;; or completion-no-auto-exit is non-nil.
8175 :
8176 : ;; Some older code may call us passing `base-size' instead of
8177 : ;; `base-position'. It's difficult to make any use of `base-size',
8178 : ;; so we just ignore it.
8179 0 : (unless (consp base-position)
8180 0 : (message "Obsolete `base-size' passed to choose-completion-string")
8181 0 : (setq base-position nil))
8182 :
8183 0 : (let* ((buffer (or buffer completion-reference-buffer))
8184 0 : (mini-p (minibufferp buffer)))
8185 : ;; If BUFFER is a minibuffer, barf unless it's the currently
8186 : ;; active minibuffer.
8187 0 : (if (and mini-p
8188 0 : (not (and (active-minibuffer-window)
8189 0 : (equal buffer
8190 0 : (window-buffer (active-minibuffer-window))))))
8191 0 : (error "Minibuffer is not active for completion")
8192 : ;; Set buffer so buffer-local choose-completion-string-functions works.
8193 0 : (set-buffer buffer)
8194 0 : (unless (run-hook-with-args-until-success
8195 : 'choose-completion-string-functions
8196 : ;; The fourth arg used to be `mini-p' but was useless
8197 : ;; (since minibufferp can be used on the `buffer' arg)
8198 : ;; and indeed unused. The last used to be `base-size', so we
8199 : ;; keep it to try and avoid breaking old code.
8200 0 : choice buffer base-position nil)
8201 : ;; This remove-text-properties should be unnecessary since `choice'
8202 : ;; comes from buffer-substring-no-properties.
8203 : ;;(remove-text-properties 0 (length choice) '(mouse-face nil) choice)
8204 : ;; Insert the completion into the buffer where it was requested.
8205 0 : (funcall (or insert-function completion-list-insert-choice-function)
8206 0 : (or (car base-position) (point))
8207 0 : (or (cadr base-position) (point))
8208 0 : choice)
8209 : ;; Update point in the window that BUFFER is showing in.
8210 0 : (let ((window (get-buffer-window buffer t)))
8211 0 : (set-window-point window (point)))
8212 : ;; If completing for the minibuffer, exit it with this choice.
8213 0 : (and (not completion-no-auto-exit)
8214 0 : (minibufferp buffer)
8215 0 : minibuffer-completion-table
8216 : ;; If this is reading a file name, and the file name chosen
8217 : ;; is a directory, don't exit the minibuffer.
8218 0 : (let* ((result (buffer-substring (field-beginning) (point)))
8219 : (bounds
8220 0 : (completion-boundaries result minibuffer-completion-table
8221 0 : minibuffer-completion-predicate
8222 0 : "")))
8223 0 : (if (eq (car bounds) (length result))
8224 : ;; The completion chosen leads to a new set of completions
8225 : ;; (e.g. it's a directory): don't exit the minibuffer yet.
8226 0 : (let ((mini (active-minibuffer-window)))
8227 0 : (select-window mini)
8228 0 : (when minibuffer-auto-raise
8229 0 : (raise-frame (window-frame mini))))
8230 0 : (exit-minibuffer))))))))
8231 :
8232 : (define-derived-mode completion-list-mode nil "Completion List"
8233 : "Major mode for buffers showing lists of possible completions.
8234 : Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\
8235 : to select the completion near point.
8236 : Or click to select one with the mouse.
8237 :
8238 : \\{completion-list-mode-map}"
8239 0 : (set (make-local-variable 'completion-base-size) nil))
8240 :
8241 : (defun completion-list-mode-finish ()
8242 : "Finish setup of the completions buffer.
8243 : Called from `temp-buffer-show-hook'."
8244 0 : (when (eq major-mode 'completion-list-mode)
8245 0 : (setq buffer-read-only t)))
8246 :
8247 : (add-hook 'temp-buffer-show-hook 'completion-list-mode-finish)
8248 :
8249 :
8250 : ;; Variables and faces used in `completion-setup-function'.
8251 :
8252 : (defcustom completion-show-help t
8253 : "Non-nil means show help message in *Completions* buffer."
8254 : :type 'boolean
8255 : :version "22.1"
8256 : :group 'completion)
8257 :
8258 : ;; This function goes in completion-setup-hook, so that it is called
8259 : ;; after the text of the completion list buffer is written.
8260 : (defun completion-setup-function ()
8261 0 : (let* ((mainbuf (current-buffer))
8262 : (base-dir
8263 : ;; FIXME: This is a bad hack. We try to set the default-directory
8264 : ;; in the *Completions* buffer so that the relative file names
8265 : ;; displayed there can be treated as valid file names, independently
8266 : ;; from the completion context. But this suffers from many problems:
8267 : ;; - It's not clear when the completions are file names. With some
8268 : ;; completion tables (e.g. bzr revision specs), the listed
8269 : ;; completions can mix file names and other things.
8270 : ;; - It doesn't pay attention to possible quoting.
8271 : ;; - With fancy completion styles, the code below will not always
8272 : ;; find the right base directory.
8273 0 : (if minibuffer-completing-file-name
8274 0 : (file-name-as-directory
8275 0 : (expand-file-name
8276 0 : (buffer-substring (minibuffer-prompt-end)
8277 0 : (- (point) (or completion-base-size 0))))))))
8278 0 : (with-current-buffer standard-output
8279 0 : (let ((base-size completion-base-size) ;Read before killing localvars.
8280 0 : (base-position completion-base-position)
8281 0 : (insert-fun completion-list-insert-choice-function))
8282 0 : (completion-list-mode)
8283 0 : (set (make-local-variable 'completion-base-size) base-size)
8284 0 : (set (make-local-variable 'completion-base-position) base-position)
8285 0 : (set (make-local-variable 'completion-list-insert-choice-function)
8286 0 : insert-fun))
8287 0 : (set (make-local-variable 'completion-reference-buffer) mainbuf)
8288 0 : (if base-dir (setq default-directory base-dir))
8289 : ;; Maybe insert help string.
8290 0 : (when completion-show-help
8291 0 : (goto-char (point-min))
8292 0 : (if (display-mouse-p)
8293 0 : (insert "Click on a completion to select it.\n"))
8294 0 : (insert (substitute-command-keys
8295 : "In this buffer, type \\[choose-completion] to \
8296 0 : select the completion near point.\n\n"))))))
8297 :
8298 : (add-hook 'completion-setup-hook 'completion-setup-function)
8299 :
8300 : (define-key minibuffer-local-completion-map [prior] 'switch-to-completions)
8301 : (define-key minibuffer-local-completion-map "\M-v" 'switch-to-completions)
8302 :
8303 : (defun switch-to-completions ()
8304 : "Select the completion list window."
8305 : (interactive)
8306 0 : (let ((window (or (get-buffer-window "*Completions*" 0)
8307 : ;; Make sure we have a completions window.
8308 0 : (progn (minibuffer-completion-help)
8309 0 : (get-buffer-window "*Completions*" 0)))))
8310 0 : (when window
8311 0 : (select-window window)
8312 : ;; In the new buffer, go to the first completion.
8313 : ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'.
8314 0 : (when (bobp)
8315 0 : (next-completion 1)))))
8316 :
8317 : ;;; Support keyboard commands to turn on various modifiers.
8318 :
8319 : ;; These functions -- which are not commands -- each add one modifier
8320 : ;; to the following event.
8321 :
8322 : (defun event-apply-alt-modifier (_ignore-prompt)
8323 : "\\<function-key-map>Add the Alt modifier to the following event.
8324 : For example, type \\[event-apply-alt-modifier] & to enter Alt-&."
8325 0 : (vector (event-apply-modifier (read-event) 'alt 22 "A-")))
8326 : (defun event-apply-super-modifier (_ignore-prompt)
8327 : "\\<function-key-map>Add the Super modifier to the following event.
8328 : For example, type \\[event-apply-super-modifier] & to enter Super-&."
8329 0 : (vector (event-apply-modifier (read-event) 'super 23 "s-")))
8330 : (defun event-apply-hyper-modifier (_ignore-prompt)
8331 : "\\<function-key-map>Add the Hyper modifier to the following event.
8332 : For example, type \\[event-apply-hyper-modifier] & to enter Hyper-&."
8333 0 : (vector (event-apply-modifier (read-event) 'hyper 24 "H-")))
8334 : (defun event-apply-shift-modifier (_ignore-prompt)
8335 : "\\<function-key-map>Add the Shift modifier to the following event.
8336 : For example, type \\[event-apply-shift-modifier] & to enter Shift-&."
8337 0 : (vector (event-apply-modifier (read-event) 'shift 25 "S-")))
8338 : (defun event-apply-control-modifier (_ignore-prompt)
8339 : "\\<function-key-map>Add the Ctrl modifier to the following event.
8340 : For example, type \\[event-apply-control-modifier] & to enter Ctrl-&."
8341 0 : (vector (event-apply-modifier (read-event) 'control 26 "C-")))
8342 : (defun event-apply-meta-modifier (_ignore-prompt)
8343 : "\\<function-key-map>Add the Meta modifier to the following event.
8344 : For example, type \\[event-apply-meta-modifier] & to enter Meta-&."
8345 0 : (vector (event-apply-modifier (read-event) 'meta 27 "M-")))
8346 :
8347 : (defun event-apply-modifier (event symbol lshiftby prefix)
8348 : "Apply a modifier flag to event EVENT.
8349 : SYMBOL is the name of this modifier, as a symbol.
8350 : LSHIFTBY is the numeric value of this modifier, in keyboard events.
8351 : PREFIX is the string that represents this modifier in an event type symbol."
8352 0 : (if (numberp event)
8353 0 : (cond ((eq symbol 'control)
8354 0 : (if (and (<= (downcase event) ?z)
8355 0 : (>= (downcase event) ?a))
8356 0 : (- (downcase event) ?a -1)
8357 0 : (if (and (<= (downcase event) ?Z)
8358 0 : (>= (downcase event) ?A))
8359 0 : (- (downcase event) ?A -1)
8360 0 : (logior (lsh 1 lshiftby) event))))
8361 0 : ((eq symbol 'shift)
8362 0 : (if (and (<= (downcase event) ?z)
8363 0 : (>= (downcase event) ?a))
8364 0 : (upcase event)
8365 0 : (logior (lsh 1 lshiftby) event)))
8366 : (t
8367 0 : (logior (lsh 1 lshiftby) event)))
8368 0 : (if (memq symbol (event-modifiers event))
8369 0 : event
8370 0 : (let ((event-type (if (symbolp event) event (car event))))
8371 0 : (setq event-type (intern (concat prefix (symbol-name event-type))))
8372 0 : (if (symbolp event)
8373 0 : event-type
8374 0 : (cons event-type (cdr event)))))))
8375 :
8376 : (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
8377 : (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
8378 : (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier)
8379 : (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier)
8380 : (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier)
8381 : (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier)
8382 :
8383 : ;;;; Keypad support.
8384 :
8385 : ;; Make the keypad keys act like ordinary typing keys. If people add
8386 : ;; bindings for the function key symbols, then those bindings will
8387 : ;; override these, so this shouldn't interfere with any existing
8388 : ;; bindings.
8389 :
8390 : ;; Also tell read-char how to handle these keys.
8391 : (mapc
8392 : (lambda (keypad-normal)
8393 : (let ((keypad (nth 0 keypad-normal))
8394 : (normal (nth 1 keypad-normal)))
8395 : (put keypad 'ascii-character normal)
8396 : (define-key function-key-map (vector keypad) (vector normal))))
8397 : ;; See also kp-keys bound in bindings.el.
8398 : '((kp-space ?\s)
8399 : (kp-tab ?\t)
8400 : (kp-enter ?\r)
8401 : (kp-separator ?,)
8402 : (kp-equal ?=)
8403 : ;; Do the same for various keys that are represented as symbols under
8404 : ;; GUIs but naturally correspond to characters.
8405 : (backspace 127)
8406 : (delete 127)
8407 : (tab ?\t)
8408 : (linefeed ?\n)
8409 : (clear ?\C-l)
8410 : (return ?\C-m)
8411 : (escape ?\e)
8412 : ))
8413 :
8414 : ;;;;
8415 : ;;;; forking a twin copy of a buffer.
8416 : ;;;;
8417 :
8418 : (defvar clone-buffer-hook nil
8419 : "Normal hook to run in the new buffer at the end of `clone-buffer'.")
8420 :
8421 : (defvar clone-indirect-buffer-hook nil
8422 : "Normal hook to run in the new buffer at the end of `clone-indirect-buffer'.")
8423 :
8424 : (defun clone-process (process &optional newname)
8425 : "Create a twin copy of PROCESS.
8426 : If NEWNAME is nil, it defaults to PROCESS' name;
8427 : NEWNAME is modified by adding or incrementing <N> at the end as necessary.
8428 : If PROCESS is associated with a buffer, the new process will be associated
8429 : with the current buffer instead.
8430 : Returns nil if PROCESS has already terminated."
8431 0 : (setq newname (or newname (process-name process)))
8432 0 : (if (string-match "<[0-9]+>\\'" newname)
8433 0 : (setq newname (substring newname 0 (match-beginning 0))))
8434 0 : (when (memq (process-status process) '(run stop open))
8435 0 : (let* ((process-connection-type (process-tty-name process))
8436 : (new-process
8437 0 : (if (memq (process-status process) '(open))
8438 0 : (let ((args (process-contact process t)))
8439 0 : (setq args (plist-put args :name newname))
8440 0 : (setq args (plist-put args :buffer
8441 0 : (if (process-buffer process)
8442 0 : (current-buffer))))
8443 0 : (apply 'make-network-process args))
8444 0 : (apply 'start-process newname
8445 0 : (if (process-buffer process) (current-buffer))
8446 0 : (process-command process)))))
8447 0 : (set-process-query-on-exit-flag
8448 0 : new-process (process-query-on-exit-flag process))
8449 0 : (set-process-inherit-coding-system-flag
8450 0 : new-process (process-inherit-coding-system-flag process))
8451 0 : (set-process-filter new-process (process-filter process))
8452 0 : (set-process-sentinel new-process (process-sentinel process))
8453 0 : (set-process-plist new-process (copy-sequence (process-plist process)))
8454 0 : new-process)))
8455 :
8456 : ;; things to maybe add (currently partly covered by `funcall mode'):
8457 : ;; - syntax-table
8458 : ;; - overlays
8459 : (defun clone-buffer (&optional newname display-flag)
8460 : "Create and return a twin copy of the current buffer.
8461 : Unlike an indirect buffer, the new buffer can be edited
8462 : independently of the old one (if it is not read-only).
8463 : NEWNAME is the name of the new buffer. It may be modified by
8464 : adding or incrementing <N> at the end as necessary to create a
8465 : unique buffer name. If nil, it defaults to the name of the
8466 : current buffer, with the proper suffix. If DISPLAY-FLAG is
8467 : non-nil, the new buffer is shown with `pop-to-buffer'. Trying to
8468 : clone a file-visiting buffer, or a buffer whose major mode symbol
8469 : has a non-nil `no-clone' property, results in an error.
8470 :
8471 : Interactively, DISPLAY-FLAG is t and NEWNAME is the name of the
8472 : current buffer with appropriate suffix. However, if a prefix
8473 : argument is given, then the command prompts for NEWNAME in the
8474 : minibuffer.
8475 :
8476 : This runs the normal hook `clone-buffer-hook' in the new buffer
8477 : after it has been set up properly in other respects."
8478 : (interactive
8479 0 : (progn
8480 0 : (if buffer-file-name
8481 0 : (error "Cannot clone a file-visiting buffer"))
8482 0 : (if (get major-mode 'no-clone)
8483 0 : (error "Cannot clone a buffer in %s mode" mode-name))
8484 0 : (list (if current-prefix-arg
8485 0 : (read-buffer "Name of new cloned buffer: " (current-buffer)))
8486 0 : t)))
8487 0 : (if buffer-file-name
8488 0 : (error "Cannot clone a file-visiting buffer"))
8489 0 : (if (get major-mode 'no-clone)
8490 0 : (error "Cannot clone a buffer in %s mode" mode-name))
8491 0 : (setq newname (or newname (buffer-name)))
8492 0 : (if (string-match "<[0-9]+>\\'" newname)
8493 0 : (setq newname (substring newname 0 (match-beginning 0))))
8494 0 : (let ((buf (current-buffer))
8495 0 : (ptmin (point-min))
8496 0 : (ptmax (point-max))
8497 0 : (pt (point))
8498 0 : (mk (if mark-active (mark t)))
8499 0 : (modified (buffer-modified-p))
8500 0 : (mode major-mode)
8501 0 : (lvars (buffer-local-variables))
8502 0 : (process (get-buffer-process (current-buffer)))
8503 0 : (new (generate-new-buffer (or newname (buffer-name)))))
8504 0 : (save-restriction
8505 0 : (widen)
8506 0 : (with-current-buffer new
8507 0 : (insert-buffer-substring buf)))
8508 0 : (with-current-buffer new
8509 0 : (narrow-to-region ptmin ptmax)
8510 0 : (goto-char pt)
8511 0 : (if mk (set-mark mk))
8512 0 : (set-buffer-modified-p modified)
8513 :
8514 : ;; Clone the old buffer's process, if any.
8515 0 : (when process (clone-process process))
8516 :
8517 : ;; Now set up the major mode.
8518 0 : (funcall mode)
8519 :
8520 : ;; Set up other local variables.
8521 0 : (mapc (lambda (v)
8522 0 : (condition-case () ;in case var is read-only
8523 0 : (if (symbolp v)
8524 0 : (makunbound v)
8525 0 : (set (make-local-variable (car v)) (cdr v)))
8526 0 : (error nil)))
8527 0 : lvars)
8528 :
8529 : ;; Run any hooks (typically set up by the major mode
8530 : ;; for cloning to work properly).
8531 0 : (run-hooks 'clone-buffer-hook))
8532 0 : (if display-flag
8533 : ;; Presumably the current buffer is shown in the selected frame, so
8534 : ;; we want to display the clone elsewhere.
8535 0 : (let ((same-window-regexps nil)
8536 : (same-window-buffer-names))
8537 0 : (pop-to-buffer new)))
8538 0 : new))
8539 :
8540 :
8541 : (defun clone-indirect-buffer (newname display-flag &optional norecord)
8542 : "Create an indirect buffer that is a twin copy of the current buffer.
8543 :
8544 : Give the indirect buffer name NEWNAME. Interactively, read NEWNAME
8545 : from the minibuffer when invoked with a prefix arg. If NEWNAME is nil
8546 : or if not called with a prefix arg, NEWNAME defaults to the current
8547 : buffer's name. The name is modified by adding a `<N>' suffix to it
8548 : or by incrementing the N in an existing suffix. Trying to clone a
8549 : buffer whose major mode symbol has a non-nil `no-clone-indirect'
8550 : property results in an error.
8551 :
8552 : DISPLAY-FLAG non-nil means show the new buffer with `pop-to-buffer'.
8553 : This is always done when called interactively.
8554 :
8555 : Optional third arg NORECORD non-nil means do not put this buffer at the
8556 : front of the list of recently selected ones.
8557 :
8558 : Returns the newly created indirect buffer."
8559 : (interactive
8560 0 : (progn
8561 0 : (if (get major-mode 'no-clone-indirect)
8562 0 : (error "Cannot indirectly clone a buffer in %s mode" mode-name))
8563 0 : (list (if current-prefix-arg
8564 0 : (read-buffer "Name of indirect buffer: " (current-buffer)))
8565 0 : t)))
8566 0 : (if (get major-mode 'no-clone-indirect)
8567 0 : (error "Cannot indirectly clone a buffer in %s mode" mode-name))
8568 0 : (setq newname (or newname (buffer-name)))
8569 0 : (if (string-match "<[0-9]+>\\'" newname)
8570 0 : (setq newname (substring newname 0 (match-beginning 0))))
8571 0 : (let* ((name (generate-new-buffer-name newname))
8572 0 : (buffer (make-indirect-buffer (current-buffer) name t)))
8573 0 : (with-current-buffer buffer
8574 0 : (run-hooks 'clone-indirect-buffer-hook))
8575 0 : (when display-flag
8576 0 : (pop-to-buffer buffer nil norecord))
8577 0 : buffer))
8578 :
8579 :
8580 : (defun clone-indirect-buffer-other-window (newname display-flag &optional norecord)
8581 : "Like `clone-indirect-buffer' but display in another window."
8582 : (interactive
8583 0 : (progn
8584 0 : (if (get major-mode 'no-clone-indirect)
8585 0 : (error "Cannot indirectly clone a buffer in %s mode" mode-name))
8586 0 : (list (if current-prefix-arg
8587 0 : (read-buffer "Name of indirect buffer: " (current-buffer)))
8588 0 : t)))
8589 0 : (let ((pop-up-windows t))
8590 0 : (clone-indirect-buffer newname display-flag norecord)))
8591 :
8592 :
8593 : ;;; Handling of Backspace and Delete keys.
8594 :
8595 : (defcustom normal-erase-is-backspace 'maybe
8596 : "Set the default behavior of the Delete and Backspace keys.
8597 :
8598 : If set to t, Delete key deletes forward and Backspace key deletes
8599 : backward.
8600 :
8601 : If set to nil, both Delete and Backspace keys delete backward.
8602 :
8603 : If set to `maybe' (which is the default), Emacs automatically
8604 : selects a behavior. On window systems, the behavior depends on
8605 : the keyboard used. If the keyboard has both a Backspace key and
8606 : a Delete key, and both are mapped to their usual meanings, the
8607 : option's default value is set to t, so that Backspace can be used
8608 : to delete backward, and Delete can be used to delete forward.
8609 :
8610 : If not running under a window system, customizing this option
8611 : accomplishes a similar effect by mapping C-h, which is usually
8612 : generated by the Backspace key, to DEL, and by mapping DEL to C-d
8613 : via `keyboard-translate'. The former functionality of C-h is
8614 : available on the F1 key. You should probably not use this
8615 : setting if you don't have both Backspace, Delete and F1 keys.
8616 :
8617 : Setting this variable with setq doesn't take effect. Programmatically,
8618 : call `normal-erase-is-backspace-mode' (which see) instead."
8619 : :type '(choice (const :tag "Off" nil)
8620 : (const :tag "Maybe" maybe)
8621 : (other :tag "On" t))
8622 : :group 'editing-basics
8623 : :version "21.1"
8624 : :set (lambda (symbol value)
8625 : ;; The fboundp is because of a problem with :set when
8626 : ;; dumping Emacs. It doesn't really matter.
8627 : (if (fboundp 'normal-erase-is-backspace-mode)
8628 : (normal-erase-is-backspace-mode (or value 0))
8629 : (set-default symbol value))))
8630 :
8631 : (defun normal-erase-is-backspace-setup-frame (&optional frame)
8632 : "Set up `normal-erase-is-backspace-mode' on FRAME, if necessary."
8633 0 : (unless frame (setq frame (selected-frame)))
8634 0 : (with-selected-frame frame
8635 0 : (unless (terminal-parameter nil 'normal-erase-is-backspace)
8636 0 : (normal-erase-is-backspace-mode
8637 0 : (if (if (eq normal-erase-is-backspace 'maybe)
8638 0 : (and (not noninteractive)
8639 0 : (or (memq system-type '(ms-dos windows-nt))
8640 0 : (memq window-system '(w32 ns))
8641 0 : (and (memq window-system '(x))
8642 0 : (fboundp 'x-backspace-delete-keys-p)
8643 0 : (x-backspace-delete-keys-p))
8644 : ;; If the terminal Emacs is running on has erase char
8645 : ;; set to ^H, use the Backspace key for deleting
8646 : ;; backward, and the Delete key for deleting forward.
8647 0 : (and (null window-system)
8648 0 : (eq tty-erase-char ?\^H))))
8649 0 : normal-erase-is-backspace)
8650 0 : 1 0)))))
8651 :
8652 : (define-minor-mode normal-erase-is-backspace-mode
8653 : "Toggle the Erase and Delete mode of the Backspace and Delete keys.
8654 : With a prefix argument ARG, enable this feature if ARG is
8655 : positive, and disable it otherwise. If called from Lisp, enable
8656 : the mode if ARG is omitted or nil.
8657 :
8658 : On window systems, when this mode is on, Delete is mapped to C-d
8659 : and Backspace is mapped to DEL; when this mode is off, both
8660 : Delete and Backspace are mapped to DEL. (The remapping goes via
8661 : `local-function-key-map', so binding Delete or Backspace in the
8662 : global or local keymap will override that.)
8663 :
8664 : In addition, on window systems, the bindings of C-Delete, M-Delete,
8665 : C-M-Delete, C-Backspace, M-Backspace, and C-M-Backspace are changed in
8666 : the global keymap in accordance with the functionality of Delete and
8667 : Backspace. For example, if Delete is remapped to C-d, which deletes
8668 : forward, C-Delete is bound to `kill-word', but if Delete is remapped
8669 : to DEL, which deletes backward, C-Delete is bound to
8670 : `backward-kill-word'.
8671 :
8672 : If not running on a window system, a similar effect is accomplished by
8673 : remapping C-h (normally produced by the Backspace key) and DEL via
8674 : `keyboard-translate': if this mode is on, C-h is mapped to DEL and DEL
8675 : to C-d; if it's off, the keys are not remapped.
8676 :
8677 : When not running on a window system, and this mode is turned on, the
8678 : former functionality of C-h is available on the F1 key. You should
8679 : probably not turn on this mode on a text-only terminal if you don't
8680 : have both Backspace, Delete and F1 keys.
8681 :
8682 : See also `normal-erase-is-backspace'."
8683 : :variable ((eq (terminal-parameter nil 'normal-erase-is-backspace) 1)
8684 : . (lambda (v)
8685 : (setf (terminal-parameter nil 'normal-erase-is-backspace)
8686 : (if v 1 0))))
8687 0 : (let ((enabled (eq 1 (terminal-parameter
8688 0 : nil 'normal-erase-is-backspace))))
8689 :
8690 0 : (cond ((or (memq window-system '(x w32 ns pc))
8691 0 : (memq system-type '(ms-dos windows-nt)))
8692 0 : (let ((bindings
8693 0 : `(([M-delete] [M-backspace])
8694 : ([C-M-delete] [C-M-backspace])
8695 0 : ([?\e C-delete] [?\e C-backspace]))))
8696 :
8697 0 : (if enabled
8698 0 : (progn
8699 0 : (define-key local-function-key-map [delete] [deletechar])
8700 0 : (define-key local-function-key-map [kp-delete] [deletechar])
8701 0 : (define-key local-function-key-map [backspace] [?\C-?])
8702 0 : (dolist (b bindings)
8703 : ;; Not sure if input-decode-map is really right, but
8704 : ;; keyboard-translate-table (used below) only works
8705 : ;; for integer events, and key-translation-table is
8706 : ;; global (like the global-map, used earlier).
8707 0 : (define-key input-decode-map (car b) nil)
8708 0 : (define-key input-decode-map (cadr b) nil)))
8709 0 : (define-key local-function-key-map [delete] [?\C-?])
8710 0 : (define-key local-function-key-map [kp-delete] [?\C-?])
8711 0 : (define-key local-function-key-map [backspace] [?\C-?])
8712 0 : (dolist (b bindings)
8713 0 : (define-key input-decode-map (car b) (cadr b))
8714 0 : (define-key input-decode-map (cadr b) (car b))))))
8715 : (t
8716 0 : (if enabled
8717 0 : (progn
8718 0 : (keyboard-translate ?\C-h ?\C-?)
8719 0 : (keyboard-translate ?\C-? ?\C-d))
8720 0 : (keyboard-translate ?\C-h ?\C-h)
8721 0 : (keyboard-translate ?\C-? ?\C-?))))
8722 :
8723 0 : (if (called-interactively-p 'interactive)
8724 0 : (message "Delete key deletes %s"
8725 0 : (if (eq 1 (terminal-parameter nil 'normal-erase-is-backspace))
8726 0 : "forward" "backward")))))
8727 :
8728 : (defvar vis-mode-saved-buffer-invisibility-spec nil
8729 : "Saved value of `buffer-invisibility-spec' when Visible mode is on.")
8730 :
8731 : (define-minor-mode read-only-mode
8732 : "Change whether the current buffer is read-only.
8733 : With prefix argument ARG, make the buffer read-only if ARG is
8734 : positive, otherwise make it writable. If buffer is read-only
8735 : and `view-read-only' is non-nil, enter view mode.
8736 :
8737 : Do not call this from a Lisp program unless you really intend to
8738 : do the same thing as the \\[read-only-mode] command, including
8739 : possibly enabling or disabling View mode. Also, note that this
8740 : command works by setting the variable `buffer-read-only', which
8741 : does not affect read-only regions caused by text properties. To
8742 : ignore read-only status in a Lisp program (whether due to text
8743 : properties or buffer state), bind `inhibit-read-only' temporarily
8744 : to a non-nil value."
8745 : :variable buffer-read-only
8746 0 : (cond
8747 0 : ((and (not buffer-read-only) view-mode)
8748 0 : (View-exit-and-edit)
8749 0 : (make-local-variable 'view-read-only)
8750 0 : (setq view-read-only t)) ; Must leave view mode.
8751 0 : ((and buffer-read-only view-read-only
8752 : ;; If view-mode is already active, `view-mode-enter' is a nop.
8753 0 : (not view-mode)
8754 0 : (not (eq (get major-mode 'mode-class) 'special)))
8755 0 : (view-mode-enter))))
8756 :
8757 : (define-minor-mode visible-mode
8758 : "Toggle making all invisible text temporarily visible (Visible mode).
8759 : With a prefix argument ARG, enable Visible mode if ARG is
8760 : positive, and disable it otherwise. If called from Lisp, enable
8761 : the mode if ARG is omitted or nil.
8762 :
8763 : This mode works by saving the value of `buffer-invisibility-spec'
8764 : and setting it to nil."
8765 : :lighter " Vis"
8766 : :group 'editing-basics
8767 0 : (when (local-variable-p 'vis-mode-saved-buffer-invisibility-spec)
8768 0 : (setq buffer-invisibility-spec vis-mode-saved-buffer-invisibility-spec)
8769 0 : (kill-local-variable 'vis-mode-saved-buffer-invisibility-spec))
8770 0 : (when visible-mode
8771 0 : (set (make-local-variable 'vis-mode-saved-buffer-invisibility-spec)
8772 0 : buffer-invisibility-spec)
8773 0 : (setq buffer-invisibility-spec nil)))
8774 :
8775 : (defvar messages-buffer-mode-map
8776 : (let ((map (make-sparse-keymap)))
8777 : (set-keymap-parent map special-mode-map)
8778 : (define-key map "g" nil) ; nothing to revert
8779 : map))
8780 :
8781 : (define-derived-mode messages-buffer-mode special-mode "Messages"
8782 : "Major mode used in the \"*Messages*\" buffer.")
8783 :
8784 : (defun messages-buffer ()
8785 : "Return the \"*Messages*\" buffer.
8786 : If it does not exist, create and it switch it to `messages-buffer-mode'."
8787 159 : (or (get-buffer "*Messages*")
8788 0 : (with-current-buffer (get-buffer-create "*Messages*")
8789 0 : (messages-buffer-mode)
8790 159 : (current-buffer))))
8791 :
8792 :
8793 : ;; Minibuffer prompt stuff.
8794 :
8795 : ;;(defun minibuffer-prompt-modification (start end)
8796 : ;; (error "You cannot modify the prompt"))
8797 : ;;
8798 : ;;
8799 : ;;(defun minibuffer-prompt-insertion (start end)
8800 : ;; (let ((inhibit-modification-hooks t))
8801 : ;; (delete-region start end)
8802 : ;; ;; Discard undo information for the text insertion itself
8803 : ;; ;; and for the text deletion.above.
8804 : ;; (when (consp buffer-undo-list)
8805 : ;; (setq buffer-undo-list (cddr buffer-undo-list)))
8806 : ;; (message "You cannot modify the prompt")))
8807 : ;;
8808 : ;;
8809 : ;;(setq minibuffer-prompt-properties
8810 : ;; (list 'modification-hooks '(minibuffer-prompt-modification)
8811 : ;; 'insert-in-front-hooks '(minibuffer-prompt-insertion)))
8812 :
8813 :
8814 : ;;;; Problematic external packages.
8815 :
8816 : ;; rms says this should be done by specifying symbols that define
8817 : ;; versions together with bad values. This is therefore not as
8818 : ;; flexible as it could be. See the thread:
8819 : ;; http://lists.gnu.org/archive/html/emacs-devel/2007-08/msg00300.html
8820 : (defconst bad-packages-alist
8821 : ;; Not sure exactly which semantic versions have problems.
8822 : ;; Definitely 2.0pre3, probably all 2.0pre's before this.
8823 : '((semantic semantic-version "\\`2\\.0pre[1-3]\\'"
8824 : "The version of `semantic' loaded does not work in Emacs 22.
8825 : It can cause constant high CPU load.
8826 : Upgrade to at least Semantic 2.0pre4 (distributed with CEDET 1.0pre4).")
8827 : ;; CUA-mode does not work with GNU Emacs version 22.1 and newer.
8828 : ;; Except for version 1.2, all of the 1.x and 2.x version of cua-mode
8829 : ;; provided the `CUA-mode' feature. Since this is no longer true,
8830 : ;; we can warn the user if the `CUA-mode' feature is ever provided.
8831 : (CUA-mode t nil
8832 : "CUA-mode is now part of the standard GNU Emacs distribution,
8833 : so you can now enable CUA via the Options menu or by customizing `cua-mode'.
8834 :
8835 : You have loaded an older version of CUA-mode which does not work
8836 : correctly with this version of Emacs. You should remove the old
8837 : version and use the one distributed with Emacs."))
8838 : "Alist of packages known to cause problems in this version of Emacs.
8839 : Each element has the form (PACKAGE SYMBOL REGEXP STRING).
8840 : PACKAGE is either a regular expression to match file names, or a
8841 : symbol (a feature name), like for `with-eval-after-load'.
8842 : SYMBOL is either the name of a string variable, or t. Upon
8843 : loading PACKAGE, if SYMBOL is t or matches REGEXP, display a
8844 : warning using STRING as the message.")
8845 :
8846 : (defun bad-package-check (package)
8847 : "Run a check using the element from `bad-packages-alist' matching PACKAGE."
8848 0 : (condition-case nil
8849 0 : (let* ((list (assoc package bad-packages-alist))
8850 0 : (symbol (nth 1 list)))
8851 0 : (and list
8852 0 : (boundp symbol)
8853 0 : (or (eq symbol t)
8854 0 : (and (stringp (setq symbol (eval symbol)))
8855 0 : (string-match-p (nth 2 list) symbol)))
8856 0 : (display-warning package (nth 3 list) :warning)))
8857 0 : (error nil)))
8858 :
8859 : (dolist (elem bad-packages-alist)
8860 : (let ((pkg (car elem)))
8861 : (with-eval-after-load pkg
8862 : (bad-package-check pkg))))
8863 :
8864 :
8865 : ;;; Generic dispatcher commands
8866 :
8867 : ;; Macro `define-alternatives' is used to create generic commands.
8868 : ;; Generic commands are these (like web, mail, news, encrypt, irc, etc.)
8869 : ;; that can have different alternative implementations where choosing
8870 : ;; among them is exclusively a matter of user preference.
8871 :
8872 : ;; (define-alternatives COMMAND) creates a new interactive command
8873 : ;; M-x COMMAND and a customizable variable COMMAND-alternatives.
8874 : ;; Typically, the user will not need to customize this variable; packages
8875 : ;; wanting to add alternative implementations should use
8876 : ;;
8877 : ;; ;;;###autoload (push '("My impl name" . my-impl-symbol) COMMAND-alternatives
8878 :
8879 : (defmacro define-alternatives (command &rest customizations)
8880 : "Define the new command `COMMAND'.
8881 :
8882 : The argument `COMMAND' should be a symbol.
8883 :
8884 : Running `M-x COMMAND RET' for the first time prompts for which
8885 : alternative to use and records the selected command as a custom
8886 : variable.
8887 :
8888 : Running `C-u M-x COMMAND RET' prompts again for an alternative
8889 : and overwrites the previous choice.
8890 :
8891 : The variable `COMMAND-alternatives' contains an alist with
8892 : alternative implementations of COMMAND. `define-alternatives'
8893 : does not have any effect until this variable is set.
8894 :
8895 : CUSTOMIZATIONS, if non-nil, should be composed of alternating
8896 : `defcustom' keywords and values to add to the declaration of
8897 : `COMMAND-alternatives' (typically :group and :version)."
8898 0 : (let* ((command-name (symbol-name command))
8899 0 : (varalt-name (concat command-name "-alternatives"))
8900 0 : (varalt-sym (intern varalt-name))
8901 0 : (varimp-sym (intern (concat command-name "--implementation"))))
8902 0 : `(progn
8903 :
8904 0 : (defcustom ,varalt-sym nil
8905 0 : ,(format "Alist of alternative implementations for the `%s' command.
8906 :
8907 : Each entry must be a pair (ALTNAME . ALTFUN), where:
8908 : ALTNAME - The name shown at user to describe the alternative implementation.
8909 : ALTFUN - The function called to implement this alternative."
8910 0 : command-name)
8911 : :type '(alist :key-type string :value-type function)
8912 0 : ,@customizations)
8913 :
8914 0 : (put ',varalt-sym 'definition-name ',command)
8915 0 : (defvar ,varimp-sym nil "Internal use only.")
8916 :
8917 0 : (defun ,command (&optional arg)
8918 0 : ,(format "Run generic command `%s'.
8919 : If used for the first time, or with interactive ARG, ask the user which
8920 : implementation to use for `%s'. The variable `%s'
8921 : contains the list of implementations currently supported for this command."
8922 0 : command-name command-name varalt-name)
8923 : (interactive "P")
8924 0 : (when (or arg (null ,varimp-sym))
8925 : (let ((val (completing-read
8926 0 : ,(format-message
8927 : "Select implementation for command `%s': "
8928 0 : command-name)
8929 0 : ,varalt-sym nil t)))
8930 : (unless (string-equal val "")
8931 0 : (when (null ,varimp-sym)
8932 : (message
8933 : "Use C-u M-x %s RET`to select another implementation"
8934 0 : ,command-name)
8935 : (sit-for 3))
8936 0 : (customize-save-variable ',varimp-sym
8937 0 : (cdr (assoc-string val ,varalt-sym))))))
8938 0 : (if ,varimp-sym
8939 0 : (call-interactively ,varimp-sym)
8940 0 : (message "%s" ,(format-message
8941 : "No implementation selected for command `%s'"
8942 0 : command-name)))))))
8943 :
8944 :
8945 : ;;; Functions for changing capitalization that Do What I Mean
8946 : (defun upcase-dwim (arg)
8947 : "Upcase words in the region, if active; if not, upcase word at point.
8948 : If the region is active, this function calls `upcase-region'.
8949 : Otherwise, it calls `upcase-word', with prefix argument passed to it
8950 : to upcase ARG words."
8951 : (interactive "*p")
8952 0 : (if (use-region-p)
8953 0 : (upcase-region (region-beginning) (region-end))
8954 0 : (upcase-word arg)))
8955 :
8956 : (defun downcase-dwim (arg)
8957 : "Downcase words in the region, if active; if not, downcase word at point.
8958 : If the region is active, this function calls `downcase-region'.
8959 : Otherwise, it calls `downcase-word', with prefix argument passed to it
8960 : to downcase ARG words."
8961 : (interactive "*p")
8962 0 : (if (use-region-p)
8963 0 : (downcase-region (region-beginning) (region-end))
8964 0 : (downcase-word arg)))
8965 :
8966 : (defun capitalize-dwim (arg)
8967 : "Capitalize words in the region, if active; if not, capitalize word at point.
8968 : If the region is active, this function calls `capitalize-region'.
8969 : Otherwise, it calls `capitalize-word', with prefix argument passed to it
8970 : to capitalize ARG words."
8971 : (interactive "*p")
8972 0 : (if (use-region-p)
8973 0 : (capitalize-region (region-beginning) (region-end))
8974 0 : (capitalize-word arg)))
8975 :
8976 :
8977 :
8978 : (provide 'simple)
8979 :
8980 : ;;; simple.el ends here
|