1;;; simple.el --- basic editing commands for Emacs -*- lexical-binding: t -*- 2 3;; Copyright (C) 1985-1987, 1993-2021 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 <https://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 idle-update-delay 0.5 41 "Idle time delay before updating various things on the screen. 42Various Emacs features that update auxiliary information when point moves 43wait this many seconds after Emacs becomes idle before doing an update." 44 :type 'number 45 :group 'display 46 :version "22.1") 47 48(defvar amalgamating-undo-limit 20 49 "The maximum number of changes to possibly amalgamate when undoing changes. 50The `undo' command will normally consider \"similar\" changes 51(like inserting characters) to be part of the same change. This 52is called \"amalgamating\" the changes. This variable says what 53the maximum number of changes considered is when amalgamating. A 54value of 1 means that nothing is amalgamated.") 55 56(defgroup killing nil 57 "Killing and yanking commands." 58 :group 'editing) 59 60(defgroup paren-matching nil 61 "Highlight (un)matching of parens and expressions." 62 :group 'matching) 63 64;;; next-error support framework 65 66(defgroup next-error nil 67 "`next-error' support framework." 68 :group 'compilation 69 :version "22.1") 70 71(defface next-error 72 '((t (:inherit region))) 73 "Face used to highlight next error locus." 74 :group 'next-error 75 :version "22.1") 76 77(defcustom next-error-highlight 0.5 78 "Highlighting of locations in the selected buffer. 79If a number, highlight the locus in `next-error' face for the given time 80in seconds, or until the next command is executed. 81If t, highlight the locus until the next command is executed, or until 82some other locus replaces it. 83If nil, don't highlight the locus in the source buffer. 84If `fringe-arrow', indicate the locus by the fringe arrow 85indefinitely until some other locus replaces it. 86See `next-error-highlight-no-select' to customize highlighting 87of the locus in non-selected buffers." 88 :type '(choice (number :tag "Highlight for specified time") 89 (const :tag "Semipermanent highlighting" t) 90 (const :tag "No highlighting" nil) 91 (const :tag "Fringe arrow" fringe-arrow)) 92 :group 'next-error 93 :version "22.1") 94 95(defcustom next-error-highlight-no-select 0.5 96 "Highlighting of locations in non-selected source buffers. 97Usually non-selected buffers are displayed by `next-error-no-select'. 98If number, highlight the locus in `next-error' face for given time in seconds. 99If t, highlight the locus indefinitely until some other locus replaces it. 100If nil, don't highlight the locus in the source buffer. 101If `fringe-arrow', indicate the locus by the fringe arrow 102indefinitely until some other locus replaces it. 103See `next-error-highlight' to customize highlighting of the locus 104in the selected buffer." 105 :type '(choice (number :tag "Highlight for specified time") 106 (const :tag "Semipermanent highlighting" t) 107 (const :tag "No highlighting" nil) 108 (const :tag "Fringe arrow" fringe-arrow)) 109 :group 'next-error 110 :version "22.1") 111 112(defcustom next-error-recenter nil 113 "Display the line in the visited source file recentered as specified. 114If non-nil, the value is passed directly to `recenter'." 115 :type '(choice (integer :tag "Line to recenter to") 116 (const :tag "Center of window" (4)) 117 (const :tag "No recentering" nil)) 118 :group 'next-error 119 :version "23.1") 120 121(defcustom next-error-message-highlight nil 122 "If non-nil, highlight the current error message in the `next-error' buffer. 123If the value is `keep', highlighting is permanent, so all visited error 124messages are highlighted; this helps to see what messages were visited." 125 :type '(choice (const :tag "Highlight the current error" t) 126 (const :tag "Highlight all visited errors" keep) 127 (const :tag "No highlighting" nil)) 128 :group 'next-error 129 :version "28.1") 130 131(defface next-error-message 132 '((t (:inherit highlight :extend t))) 133 "Face used to highlight the current error message in the `next-error' buffer." 134 :group 'next-error 135 :version "28.1") 136 137(defvar-local next-error--message-highlight-overlay 138 nil 139 "Overlay highlighting the current error message in the `next-error' buffer.") 140 141(defvar global-minor-modes nil 142 "A list of the currently enabled global minor modes. 143This is a list of symbols.") 144 145(defcustom next-error-hook nil 146 "List of hook functions run by `next-error' after visiting source file." 147 :type 'hook 148 :group 'next-error) 149 150(defcustom next-error-verbose t 151 "If non-nil, `next-error' always outputs the current error buffer. 152If nil, the message is output only when the error buffer 153changes." 154 :group 'next-error 155 :type 'boolean 156 :safe #'booleanp 157 :version "27.1") 158 159(defvar next-error-highlight-timer nil) 160 161(defvar next-error-overlay-arrow-position nil) 162(put 'next-error-overlay-arrow-position 'overlay-arrow-string (purecopy "=>")) 163(add-to-list 'overlay-arrow-variable-list 'next-error-overlay-arrow-position) 164 165(defvar next-error-last-buffer nil 166 "The most recent `next-error' buffer. 167A buffer becomes most recent when its compilation, grep, or 168similar mode is started, or when it is used with \\[next-error] 169or \\[compile-goto-error].") 170 171(defvar-local next-error-buffer nil 172 "The buffer-local value of the most recent `next-error' buffer.") 173;; next-error-buffer is made buffer-local to keep the reference 174;; to the parent buffer used to navigate to the current buffer, so the 175;; next call of next-buffer will use the same parent buffer to 176;; continue navigation from it. 177 178(defvar-local next-error-function nil 179 "Function to use to find the next error in the current buffer. 180The function is called with 2 parameters: 181ARG is an integer specifying by how many errors to move. 182RESET is a boolean which, if non-nil, says to go back to the beginning 183of the errors before moving. 184Major modes providing compile-like functionality should set this variable 185to indicate to `next-error' that this is a candidate buffer and how 186to navigate in it.") 187 188(defvar-local next-error-move-function nil 189 "Function to use to move to an error locus. 190It takes two arguments, a buffer position in the error buffer 191and a buffer position in the error locus buffer. 192The buffer for the error locus should already be current. 193nil means use `goto-char' using the second argument position.") 194 195(defsubst next-error-buffer-p (buffer 196 &optional avoid-current 197 extra-test-inclusive 198 extra-test-exclusive) 199 "Return non-nil if BUFFER is a `next-error' capable buffer. 200If AVOID-CURRENT is non-nil, and BUFFER is the current buffer, 201return nil. 202 203The function EXTRA-TEST-INCLUSIVE, if non-nil, is called if 204BUFFER would not normally qualify. If it returns non-nil, BUFFER 205is considered `next-error' capable, anyway, and the function 206returns non-nil. 207 208The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called if the 209buffer would normally qualify. If it returns nil, BUFFER is 210rejected, and the function returns nil." 211 (and (buffer-name buffer) ;First make sure it's live. 212 (not (and avoid-current (eq buffer (current-buffer)))) 213 (with-current-buffer buffer 214 (if next-error-function ; This is the normal test. 215 ;; Optionally reject some buffers. 216 (if extra-test-exclusive 217 (funcall extra-test-exclusive) 218 t) 219 ;; Optionally accept some other buffers. 220 (and extra-test-inclusive 221 (funcall extra-test-inclusive)))))) 222 223(defcustom next-error-find-buffer-function #'ignore 224 "Function called to find a `next-error' capable buffer. 225This functions takes the same three arguments as the function 226`next-error-find-buffer', and should return the buffer to be 227used by the subsequent invocation of the command `next-error' 228and `previous-error'. 229If the function returns nil, `next-error-find-buffer' will 230try to use the buffer it used previously, and failing that 231all other buffers." 232 :type '(choice (const :tag "No default" ignore) 233 (const :tag "Single next-error capable buffer on selected frame" 234 next-error-buffer-on-selected-frame) 235 (const :tag "Current buffer if next-error capable and outside navigation" 236 next-error-buffer-unnavigated-current) 237 (function :tag "Other function")) 238 :group 'next-error 239 :version "28.1") 240 241(defun next-error-buffer-on-selected-frame (&optional _avoid-current 242 extra-test-inclusive 243 extra-test-exclusive) 244 "Return a single visible `next-error' buffer on the selected frame." 245 (let ((window-buffers 246 (delete-dups 247 (delq nil (mapcar (lambda (w) 248 (if (next-error-buffer-p 249 (window-buffer w) 250 t 251 extra-test-inclusive extra-test-exclusive) 252 (window-buffer w))) 253 (window-list)))))) 254 (if (eq (length window-buffers) 1) 255 (car window-buffers)))) 256 257(defun next-error-buffer-unnavigated-current (&optional avoid-current 258 extra-test-inclusive 259 extra-test-exclusive) 260 "Try the current buffer when outside navigation. 261But return nil if we navigated to the current buffer by the means 262of `next-error' command. Otherwise, return it if it's `next-error' 263capable." 264 ;; Check that next-error-buffer has no buffer-local value 265 ;; (i.e. we never navigated to the current buffer from another), 266 ;; and the current buffer is a `next-error' capable buffer. 267 (if (and (not (local-variable-p 'next-error-buffer)) 268 (next-error-buffer-p (current-buffer) avoid-current 269 extra-test-inclusive extra-test-exclusive)) 270 (current-buffer))) 271 272(defun next-error-find-buffer (&optional avoid-current 273 extra-test-inclusive 274 extra-test-exclusive) 275 "Return a `next-error' capable buffer. 276 277If AVOID-CURRENT is non-nil, treat the current buffer 278as an absolute last resort only. 279 280The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer 281that normally would not qualify. If it returns t, the buffer 282in question is treated as usable. 283 284The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called in each buffer 285that would normally be considered usable. If it returns nil, 286that buffer is rejected." 287 (or 288 ;; 1. If a customizable function returns a buffer, use it. 289 (funcall next-error-find-buffer-function avoid-current 290 extra-test-inclusive 291 extra-test-exclusive) 292 ;; 2. If next-error-last-buffer is an acceptable buffer, use that. 293 (if (and next-error-last-buffer 294 (next-error-buffer-p next-error-last-buffer avoid-current 295 extra-test-inclusive extra-test-exclusive)) 296 next-error-last-buffer) 297 ;; 3. If the current buffer is acceptable, choose it. 298 (if (next-error-buffer-p (current-buffer) avoid-current 299 extra-test-inclusive extra-test-exclusive) 300 (current-buffer)) 301 ;; 4. Look for any acceptable buffer. 302 (let ((buffers (buffer-list))) 303 (while (and buffers 304 (not (next-error-buffer-p 305 (car buffers) avoid-current 306 extra-test-inclusive extra-test-exclusive))) 307 (setq buffers (cdr buffers))) 308 (car buffers)) 309 ;; 5. Use the current buffer as a last resort if it qualifies, 310 ;; even despite AVOID-CURRENT. 311 (and avoid-current 312 (next-error-buffer-p (current-buffer) nil 313 extra-test-inclusive extra-test-exclusive) 314 (progn 315 (message "This is the only buffer with error message locations") 316 (current-buffer))) 317 ;; 6. Give up. 318 (error "No buffers contain error message locations"))) 319 320(defun next-error (&optional arg reset) 321 "Visit next `next-error' message and corresponding source code. 322 323If all the error messages parsed so far have been processed already, 324the message buffer is checked for new ones. 325 326A prefix ARG specifies how many error messages to move; 327negative means move back to previous error messages. 328Just \\[universal-argument] as a prefix means reparse the error message buffer 329and start at the first error. 330 331The RESET argument specifies that we should restart from the beginning. 332 333\\[next-error] normally uses the most recently started 334compilation, grep, or occur buffer. It can also operate on any 335buffer with output from the \\[compile], \\[grep] commands, or, 336more generally, on any buffer in Compilation mode or with 337Compilation Minor mode enabled, or any buffer in which 338`next-error-function' is bound to an appropriate function. 339To specify use of a particular buffer for error messages, type 340\\[next-error] in that buffer. You can also use the command 341`next-error-select-buffer' to select the buffer to use for the subsequent 342invocation of `next-error'. 343 344Once \\[next-error] has chosen the buffer for error messages, it 345runs `next-error-hook' with `run-hooks', and stays with that buffer 346until you use it in some other buffer that uses Compilation mode 347or Compilation Minor mode. 348 349To control which errors are matched, customize the variable 350`compilation-error-regexp-alist'." 351 (interactive "P") 352 (if (consp arg) (setq reset t arg nil)) 353 (let ((buffer (next-error-find-buffer))) 354 (when buffer 355 ;; We know here that next-error-function is a valid symbol we can funcall 356 (with-current-buffer buffer 357 (funcall next-error-function (prefix-numeric-value arg) reset) 358 (let ((prev next-error-last-buffer)) 359 (next-error-found buffer (current-buffer)) 360 (when (or next-error-verbose 361 (not (eq prev next-error-last-buffer))) 362 (message "%s locus from %s" 363 (cond (reset "First") 364 ((eq (prefix-numeric-value arg) 0) "Current") 365 ((< (prefix-numeric-value arg) 0) "Previous") 366 (t "Next")) 367 next-error-last-buffer))))))) 368 369(defun next-error-internal () 370 "Visit the source code corresponding to the `next-error' message at point." 371 (let ((buffer (current-buffer))) 372 ;; We know here that next-error-function is a valid symbol we can funcall 373 (funcall next-error-function 0 nil) 374 (let ((prev next-error-last-buffer)) 375 (next-error-found buffer (current-buffer)) 376 (when (or next-error-verbose 377 (not (eq prev next-error-last-buffer))) 378 (message "Current locus from %s" next-error-last-buffer))))) 379 380(defun next-error-quit-window (from-buffer to-buffer) 381 "Quit window of FROM-BUFFER when the prefix arg is 0. 382Intended to be used in `next-error-found-function'." 383 (when (and (eq current-prefix-arg 0) from-buffer 384 (not (eq from-buffer to-buffer))) 385 (let ((window (get-buffer-window from-buffer))) 386 (when (window-live-p window) 387 (quit-restore-window window))))) 388 389(defcustom next-error-found-function #'ignore 390 "Function called when a next locus is found and displayed. 391Function is called with two arguments: a FROM-BUFFER buffer 392from which `next-error' navigated, and a target buffer TO-BUFFER." 393 :type '(choice (const :tag "No default" ignore) 394 (const :tag "Quit previous window with M-0" 395 next-error-quit-window) 396 (function :tag "Other function")) 397 :group 'next-error 398 :version "27.1") 399 400(defun next-error-found (&optional from-buffer to-buffer) 401 "Function to call when the next locus is found and displayed. 402FROM-BUFFER is a buffer from which `next-error' navigated, 403and TO-BUFFER is a target buffer." 404 (setq next-error-last-buffer (or from-buffer (current-buffer))) 405 (when to-buffer 406 (with-current-buffer to-buffer 407 (setq next-error-buffer from-buffer))) 408 (when next-error-recenter 409 (recenter next-error-recenter)) 410 (funcall next-error-found-function from-buffer to-buffer) 411 (next-error-message-highlight from-buffer) 412 (run-hooks 'next-error-hook)) 413 414(defun next-error-select-buffer (buffer) 415 "Select a `next-error' capable BUFFER and set it as the last used. 416This means that the selected buffer becomes the source of locations 417for the subsequent invocation of `next-error' or `previous-error'. 418Interactively, this command allows selection only among buffers 419where `next-error-function' is bound to an appropriate function." 420 (interactive 421 (list (get-buffer 422 (read-buffer "Select next-error buffer: " nil nil 423 (lambda (b) (next-error-buffer-p (cdr b))))))) 424 (setq next-error-last-buffer buffer)) 425 426(defalias 'goto-next-locus 'next-error) 427(defalias 'next-match 'next-error) 428 429(defun previous-error (&optional n) 430 "Visit previous `next-error' message and corresponding source code. 431 432Prefix arg N says how many error messages to move backwards (or 433forwards, if negative). 434 435This operates on the output from the \\[compile] and \\[grep] commands. 436 437See `next-error' for the details." 438 (interactive "p") 439 (next-error (- (or n 1)))) 440 441(defun first-error (&optional n) 442 "Restart at the first error. 443Visit corresponding source code. 444With prefix arg N, visit the source code of the Nth error. 445This operates on the output from the \\[compile] command, for instance." 446 (interactive "p") 447 (next-error n t)) 448 449(defun next-error-no-select (&optional n) 450 "Move point to the next error in the `next-error' buffer and highlight match. 451Prefix arg N says how many error messages to move forwards (or 452backwards, if negative). 453Finds and highlights the source line like \\[next-error], but does not 454select the source buffer." 455 (interactive "p") 456 (save-selected-window 457 (let ((next-error-highlight next-error-highlight-no-select) 458 (display-buffer-overriding-action 459 '(nil (inhibit-same-window . t)))) 460 (next-error n)))) 461 462(defun previous-error-no-select (&optional n) 463 "Move point to the previous error in the `next-error' buffer and highlight match. 464Prefix arg N says how many error messages to move backwards (or 465forwards, if negative). 466Finds and highlights the source line like \\[previous-error], but does not 467select the source buffer." 468 (interactive "p") 469 (next-error-no-select (- (or n 1)))) 470 471;; Internal variable for `next-error-follow-mode-post-command-hook'. 472(defvar next-error-follow-last-line nil) 473 474(define-minor-mode next-error-follow-minor-mode 475 "Minor mode for compilation, occur and diff modes. 476 477When turned on, cursor motion in the compilation, grep, occur or diff 478buffer causes automatic display of the corresponding source code location." 479 :group 'next-error :init-value nil :lighter " Fol" 480 (if (not next-error-follow-minor-mode) 481 (remove-hook 'post-command-hook 'next-error-follow-mode-post-command-hook t) 482 (add-hook 'post-command-hook 'next-error-follow-mode-post-command-hook nil t) 483 (make-local-variable 'next-error-follow-last-line))) 484 485;; Used as a `post-command-hook' by `next-error-follow-mode' 486;; for the *Compilation* *grep* and *Occur* buffers. 487(defun next-error-follow-mode-post-command-hook () 488 (unless (equal next-error-follow-last-line (line-number-at-pos)) 489 (setq next-error-follow-last-line (line-number-at-pos)) 490 (condition-case nil 491 (let ((compilation-context-lines nil)) 492 (setq compilation-current-error (point)) 493 (next-error-no-select 0)) 494 (error t)))) 495 496(defun next-error-message-highlight (error-buffer) 497 "Highlight the current error message in the ‘next-error’ buffer." 498 (when next-error-message-highlight 499 (with-current-buffer error-buffer 500 (when (and next-error--message-highlight-overlay 501 (not (eq next-error-message-highlight 'keep))) 502 (delete-overlay next-error--message-highlight-overlay)) 503 (let ((ol (make-overlay (line-beginning-position) (1+ (line-end-position))))) 504 ;; do not override region highlighting 505 (overlay-put ol 'priority -50) 506 (overlay-put ol 'face 'next-error-message) 507 (overlay-put ol 'window (get-buffer-window)) 508 (setf next-error--message-highlight-overlay ol))))) 509 510(defun recenter-current-error (&optional arg) 511 "Recenter the current displayed error in the `next-error' buffer." 512 (interactive "P") 513 (save-selected-window 514 (let ((next-error-highlight next-error-highlight-no-select) 515 (display-buffer-overriding-action 516 '(nil (inhibit-same-window . t)))) 517 (next-error 0) 518 (set-buffer (window-buffer)) 519 (recenter-top-bottom arg)))) 520 521;;; 522 523(defun fundamental-mode () 524 "Major mode not specialized for anything in particular. 525Other major modes are defined by comparison with this one." 526 (interactive) 527 (kill-all-local-variables) 528 (run-mode-hooks)) 529 530(define-derived-mode clean-mode fundamental-mode "Clean" 531 "A mode that removes all overlays and text properties." 532 (kill-all-local-variables t) 533 (let ((inhibit-read-only t)) 534 (dolist (overlay (overlays-in (point-min) (point-max))) 535 (delete-overlay overlay)) 536 (set-text-properties (point-min) (point-max) nil) 537 (setq-local yank-excluded-properties t))) 538 539;; Special major modes to view specially formatted data rather than files. 540 541(defvar-keymap special-mode-map 542 :suppress t 543 "q" #'quit-window 544 "SPC" #'scroll-up-command 545 "S-SPC" #'scroll-down-command 546 "DEL" #'scroll-down-command 547 "?" #'describe-mode 548 "h" #'describe-mode 549 ">" #'end-of-buffer 550 "<" #'beginning-of-buffer 551 "g" #'revert-buffer) 552 553(put 'special-mode 'mode-class 'special) 554(define-derived-mode special-mode nil "Special" 555 "Parent major mode from which special major modes should inherit. 556 557A special major mode is intended to view specially formatted data 558rather than files. These modes usually use read-only buffers." 559 (setq buffer-read-only t)) 560 561;; Making and deleting lines. 562 563(defvar self-insert-uses-region-functions nil 564 "Special hook to tell if `self-insert-command' will use the region. 565It must be called via `run-hook-with-args-until-success' with no arguments. 566 567If any function on this hook returns a non-nil value, `delete-selection-mode' 568will act on that value (see `delete-selection-helper') and will 569usually delete the region. If all the functions on this hook return 570nil, it is an indication that `self-insert-command' needs the region 571untouched by `delete-selection-mode' and will itself do whatever is 572appropriate with the region. 573Any function on `post-self-insert-hook' that acts on the region should 574add a function to this hook so that `delete-selection-mode' could 575refrain from deleting the region before the `post-self-insert-hook' 576functions are called. 577This hook is run by `delete-selection-uses-region-p', which see.") 578 579(defvar hard-newline (propertize "\n" 'hard t 'rear-nonsticky '(hard)) 580 "Propertized string representing a hard newline character.") 581 582(defun newline (&optional arg interactive) 583 "Insert a newline, and move to left margin of the new line. 584With prefix argument ARG, insert that many newlines. 585 586If `electric-indent-mode' is enabled, this indents the final new line 587that it adds, and reindents the preceding line. To just insert 588a newline, use \\[electric-indent-just-newline]. 589 590If `auto-fill-mode' is enabled, this may cause automatic line 591breaking of the preceding line. A non-nil ARG inhibits this. 592 593If `use-hard-newlines' is enabled, the newline is marked with the 594text-property `hard'. 595 596A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'." 597 (interactive "*P\np") 598 (barf-if-buffer-read-only) 599 (when (and arg 600 (< (prefix-numeric-value arg) 0)) 601 (error "Repetition argument has to be non-negative")) 602 ;; Call self-insert so that auto-fill, abbrev expansion etc. happen. 603 ;; Set last-command-event to tell self-insert what to insert. 604 (let* ((was-page-start (and (bolp) (looking-at page-delimiter))) 605 (beforepos (point)) 606 (last-command-event ?\n) 607 ;; Don't auto-fill if we have a prefix argument. 608 (auto-fill-function (if arg nil auto-fill-function)) 609 (arg (prefix-numeric-value arg)) 610 (procsym (make-symbol "newline-postproc")) ;(bug#46326) 611 (postproc 612 ;; Do the rest in post-self-insert-hook, because we want to do it 613 ;; *before* other functions on that hook. 614 (lambda () 615 (remove-hook 'post-self-insert-hook procsym t) 616 ;; Mark the newline(s) `hard'. 617 (if use-hard-newlines 618 (set-hard-newline-properties 619 (- (point) arg) (point))) 620 ;; If the newline leaves the previous line blank, and we 621 ;; have a left margin, delete that from the blank line. 622 (save-excursion 623 (goto-char beforepos) 624 (beginning-of-line) 625 (and (looking-at "[ \t]+$") 626 (> (current-left-margin) 0) 627 (delete-region (point) 628 (line-end-position)))) 629 ;; Indent the line after the newline, except in one case: 630 ;; when we added the newline at the beginning of a line that 631 ;; starts a page. 632 (or was-page-start 633 (move-to-left-margin nil t))))) 634 (fset procsym postproc) 635 (if (not interactive) 636 ;; FIXME: For non-interactive uses, many calls actually 637 ;; just want (insert "\n"), so maybe we should do just 638 ;; that, so as to avoid the risk of filling or running 639 ;; abbrevs unexpectedly. 640 (let ((post-self-insert-hook (list postproc))) 641 (self-insert-command arg)) 642 (unwind-protect 643 (progn 644 (add-hook 'post-self-insert-hook procsym nil t) 645 (self-insert-command arg)) 646 ;; We first used let-binding to protect the hook, but that 647 ;; was naive since add-hook affects the symbol-default 648 ;; value of the variable, whereas the let-binding might 649 ;; protect only the buffer-local value. 650 (remove-hook 'post-self-insert-hook procsym t)))) 651 nil) 652 653(defun set-hard-newline-properties (from to) 654 (let ((sticky (get-text-property from 'rear-nonsticky))) 655 (put-text-property from to 'hard 't) 656 ;; If rear-nonsticky is not "t", add 'hard to rear-nonsticky list 657 (if (and (listp sticky) (not (memq 'hard sticky))) 658 (put-text-property from (point) 'rear-nonsticky 659 (cons 'hard sticky))))) 660 661(defun open-line (n) 662 "Insert a newline and leave point before it. 663If there is a fill prefix and/or a `left-margin', insert them on 664the new line if the line would have been blank. 665With arg N, insert N newlines." 666 (interactive "*p") 667 (let* ((do-fill-prefix (and fill-prefix (bolp))) 668 (do-left-margin (and (bolp) (> (current-left-margin) 0))) 669 (loc (point-marker)) 670 ;; Don't expand an abbrev before point. 671 (abbrev-mode nil)) 672 (newline n) 673 (goto-char loc) 674 (while (> n 0) 675 (cond ((bolp) 676 (if do-left-margin (indent-to (current-left-margin))) 677 (if do-fill-prefix (insert-and-inherit fill-prefix)))) 678 (forward-line 1) 679 (setq n (1- n))) 680 (goto-char loc) 681 ;; Necessary in case a margin or prefix was inserted. 682 (end-of-line))) 683 684(defun split-line (&optional arg) 685 "Split current line, moving portion beyond point vertically down. 686If the current line starts with `fill-prefix', insert it on the new 687line as well. With prefix ARG, don't insert `fill-prefix' on new line. 688 689When called from Lisp code, ARG may be a prefix string to copy." 690 (interactive "*P") 691 (skip-chars-forward " \t") 692 (let* ((col (current-column)) 693 (pos (point)) 694 ;; What prefix should we check for (nil means don't). 695 (prefix (cond ((stringp arg) arg) 696 (arg nil) 697 (t fill-prefix))) 698 ;; Does this line start with it? 699 (have-prfx (and prefix 700 (save-excursion 701 (beginning-of-line) 702 (looking-at (regexp-quote prefix)))))) 703 (newline 1) 704 (if have-prfx (insert-and-inherit prefix)) 705 (indent-to col 0) 706 (goto-char pos))) 707 708(defface separator-line 709 '((((type graphic) (background dark)) 710 :height 0.1 :background "#505050") 711 (((type graphic) (background light)) 712 :height 0.1 :background "#a0a0a0") 713 (t 714 :foreground "ForestGreen" :underline t)) 715 "Face for separator lines." 716 :version "29.1" 717 :group 'text) 718 719(defun make-separator-line (&optional length) 720 "Make a string appropriate for usage as a visual separator line. 721This uses the `separator-line' face. 722 723If LENGTH is nil, use the window width." 724 (if (or (display-graphic-p) 725 (display-supports-face-attributes-p '(:underline t))) 726 (if length 727 (concat (propertize (make-string length ?\s) 'face 'separator-line) 728 "\n") 729 (propertize "\n" 'face '(:inherit separator-line :extend t))) 730 ;; In terminals (that don't support underline), use a line of dashes. 731 (concat (propertize (make-string (or length (1- (window-width))) ?-) 732 'face 'separator-line) 733 "\n"))) 734 735(defun delete-indentation (&optional arg beg end) 736 "Join this line to previous and fix up whitespace at join. 737If there is a fill prefix, delete it from the beginning of this 738line. 739With prefix ARG, join the current line to the following line. 740When BEG and END are non-nil, join all lines in the region they 741define. Interactively, BEG and END are, respectively, the start 742and end of the region if it is active, else nil. (The region is 743ignored if prefix ARG is given.)" 744 (interactive 745 (progn (barf-if-buffer-read-only) 746 (cons current-prefix-arg 747 (and (use-region-p) 748 (list (region-beginning) (region-end)))))) 749 ;; Consistently deactivate mark even when no text is changed. 750 (setq deactivate-mark t) 751 (if (and beg (not arg)) 752 ;; Region is active. Go to END, but only if region spans 753 ;; multiple lines. 754 (and (goto-char beg) 755 (> end (line-end-position)) 756 (goto-char end)) 757 ;; Region is inactive. Set a loop sentinel 758 ;; (subtracting 1 in order to compare less than BOB). 759 (setq beg (1- (line-beginning-position (and arg 2)))) 760 (when arg (forward-line))) 761 (let ((prefix (and (> (length fill-prefix) 0) 762 (regexp-quote fill-prefix)))) 763 (while (and (> (line-beginning-position) beg) 764 (forward-line 0) 765 (= (preceding-char) ?\n)) 766 (delete-char -1) 767 ;; If the appended line started with the fill prefix, 768 ;; delete the prefix. 769 (if (and prefix (looking-at prefix)) 770 (replace-match "" t t)) 771 (fixup-whitespace)))) 772 773(defalias 'join-line #'delete-indentation) ; easier to find 774 775(defun delete-blank-lines () 776 "On blank line, delete all surrounding blank lines, leaving just one. 777On isolated blank line, delete that one. 778On nonblank line, delete any immediately following blank lines." 779 (interactive "*") 780 (let (thisblank singleblank) 781 (save-excursion 782 (beginning-of-line) 783 (setq thisblank (looking-at "[ \t]*$")) 784 ;; Set singleblank if there is just one blank line here. 785 (setq singleblank 786 (and thisblank 787 (not (looking-at "[ \t]*\n[ \t]*$")) 788 (or (bobp) 789 (progn (forward-line -1) 790 (not (looking-at "[ \t]*$"))))))) 791 ;; Delete preceding blank lines, and this one too if it's the only one. 792 (if thisblank 793 (progn 794 (beginning-of-line) 795 (if singleblank (forward-line 1)) 796 (delete-region (point) 797 (if (re-search-backward "[^ \t\n]" nil t) 798 (progn (forward-line 1) (point)) 799 (point-min))))) 800 ;; Delete following blank lines, unless the current line is blank 801 ;; and there are no following blank lines. 802 (if (not (and thisblank singleblank)) 803 (save-excursion 804 (end-of-line) 805 (forward-line 1) 806 (delete-region (point) 807 (if (re-search-forward "[^ \t\n]" nil t) 808 (progn (beginning-of-line) (point)) 809 (point-max))))) 810 ;; Handle the special case where point is followed by newline and eob. 811 ;; Delete the line, leaving point at eob. 812 (if (looking-at "^[ \t]*\n\\'") 813 (delete-region (point) (point-max))))) 814 815(defcustom delete-trailing-lines t 816 "If non-nil, \\[delete-trailing-whitespace] deletes trailing lines. 817Trailing lines are deleted only if `delete-trailing-whitespace' 818is called on the entire buffer (rather than an active region)." 819 :type 'boolean 820 :group 'editing 821 :version "24.3") 822 823(defun region-modifiable-p (start end) 824 "Return non-nil if the region contains no read-only text." 825 (and (not (get-text-property start 'read-only)) 826 (eq end (next-single-property-change start 'read-only nil end)))) 827 828(defun delete-trailing-whitespace (&optional start end) 829 "Delete trailing whitespace between START and END. 830If called interactively, START and END are the start/end of the 831region if the mark is active, or of the buffer's accessible 832portion if the mark is inactive. 833 834This command deletes whitespace characters after the last 835non-whitespace character in each line between START and END. It 836does not consider formfeed characters to be whitespace. 837 838If this command acts on the entire buffer (i.e. if called 839interactively with the mark inactive, or called from Lisp with 840END nil), it also deletes all trailing lines at the end of the 841buffer if the variable `delete-trailing-lines' is non-nil." 842 (interactive (progn 843 (barf-if-buffer-read-only) 844 (if (use-region-p) 845 (list (region-beginning) (region-end)) 846 (list nil nil)))) 847 (save-match-data 848 (save-excursion 849 (let ((end-marker (and end (copy-marker end)))) 850 (goto-char (or start (point-min))) 851 (with-syntax-table (make-syntax-table (syntax-table)) 852 ;; Don't delete formfeeds, even if they are considered whitespace. 853 (modify-syntax-entry ?\f "_") 854 (while (re-search-forward "\\s-$" end-marker t) 855 (skip-syntax-backward "-" (line-beginning-position)) 856 (let ((b (point)) (e (match-end 0))) 857 (if (region-modifiable-p b e) 858 (delete-region b e) 859 (goto-char e))))) 860 (if end 861 (set-marker end-marker nil) 862 ;; Delete trailing empty lines. 863 (and delete-trailing-lines 864 ;; Really the end of buffer. 865 (= (goto-char (point-max)) (1+ (buffer-size))) 866 (<= (skip-chars-backward "\n") -2) 867 (region-modifiable-p (1+ (point)) (point-max)) 868 (delete-region (1+ (point)) (point-max))))))) 869 ;; Return nil for the benefit of `write-file-functions'. 870 nil) 871 872(defun newline-and-indent (&optional arg) 873 "Insert a newline, then indent according to major mode. 874Indentation is done using the value of `indent-line-function'. 875In programming language modes, this is the same as TAB. 876In some text modes, where TAB inserts a tab, this command indents to the 877column specified by the function `current-left-margin'. 878 879With ARG, perform this action that many times. 880 881Also see `open-line' (bound to \\[open-line]) for a command that 882just inserts a newline without doing any indentation." 883 (interactive "*p") 884 (delete-horizontal-space t) 885 (unless arg 886 (setq arg 1)) 887 (let ((electric-indent-mode nil)) 888 (dotimes (_ arg) 889 (newline nil t) 890 (indent-according-to-mode)))) 891 892(defun reindent-then-newline-and-indent () 893 "Reindent current line, insert newline, then indent the new line. 894Indentation of both lines is done according to the current major mode, 895which means calling the current value of `indent-line-function'. 896In programming language modes, this is the same as TAB. 897In some text modes, where TAB inserts a tab, this indents to the 898column specified by the function `current-left-margin'." 899 (interactive "*") 900 (let ((pos (point)) 901 (electric-indent-mode nil)) 902 ;; Be careful to insert the newline before indenting the line. 903 ;; Otherwise, the indentation might be wrong. 904 (newline) 905 (save-excursion 906 (goto-char pos) 907 ;; We are at EOL before the call to indent-according-to-mode, and 908 ;; after it we usually are as well, but not always. We tried to 909 ;; address it with `save-excursion' but that uses a normal marker 910 ;; whereas we need `move after insertion', so we do the save/restore 911 ;; by hand. 912 (setq pos (copy-marker pos t)) 913 (indent-according-to-mode) 914 (goto-char pos) 915 ;; Remove the trailing white-space after indentation because 916 ;; indentation may introduce the whitespace. 917 (delete-horizontal-space t)) 918 (indent-according-to-mode))) 919 920(defcustom read-quoted-char-radix 8 921 "Radix for \\[quoted-insert] and other uses of `read-quoted-char'. 922Legitimate radix values are 8, 10 and 16." 923 :type '(choice (const 8) (const 10) (const 16)) 924 :group 'editing-basics) 925 926(defun read-quoted-char (&optional prompt) 927 "Like `read-char', but do not allow quitting. 928Also, if the first character read is an octal digit, 929we read any number of octal digits and return the 930specified character code. Any nondigit terminates the sequence. 931If the terminator is RET, it is discarded; 932any other terminator is used itself as input. 933 934The optional argument PROMPT specifies a string to use to prompt the user. 935The variable `read-quoted-char-radix' controls which radix to use 936for numeric input." 937 (let ((message-log-max nil) 938 (help-events (delq nil (mapcar (lambda (c) (unless (characterp c) c)) 939 help-event-list))) 940 done (first t) (code 0) char translated) 941 (while (not done) 942 (let ((inhibit-quit first) 943 ;; Don't let C-h or other help chars get the help 944 ;; message--only help function keys. See bug#16617. 945 (help-char nil) 946 (help-event-list help-events) 947 (help-form 948 "Type the special character you want to use, 949or the octal character code. 950RET terminates the character code and is discarded; 951any other non-digit terminates the character code and is then used as input.")) 952 (setq char (read-event (and prompt (format "%s-" prompt)) t)) 953 (if inhibit-quit (setq quit-flag nil))) 954 ;; Translate TAB key into control-I ASCII character, and so on. 955 ;; Note: `read-char' does it using the `ascii-character' property. 956 ;; We tried using read-key instead, but that disables the keystroke 957 ;; echo produced by 'C-q', see bug#24635. 958 (let ((translation (lookup-key local-function-key-map (vector char)))) 959 (setq translated (if (arrayp translation) 960 (aref translation 0) 961 char))) 962 (if (integerp translated) 963 (setq translated (char-resolve-modifiers translated))) 964 (cond ((null translated)) 965 ((not (integerp translated)) 966 (setq unread-command-events (list char) 967 done t)) 968 ((/= (logand translated ?\M-\^@) 0) 969 ;; Turn a meta-character into a character with the 0200 bit set. 970 (setq code (logior (logand translated (lognot ?\M-\^@)) 128) 971 done t)) 972 ((and (<= ?0 translated) 973 (< translated (+ ?0 (min 10 read-quoted-char-radix)))) 974 (setq code (+ (* code read-quoted-char-radix) (- translated ?0))) 975 (and prompt (setq prompt (message "%s %c" prompt translated)))) 976 ((and (<= ?a (downcase translated)) 977 (< (downcase translated) 978 (+ ?a -10 (min 36 read-quoted-char-radix)))) 979 (setq code (+ (* code read-quoted-char-radix) 980 (+ 10 (- (downcase translated) ?a)))) 981 (and prompt (setq prompt (message "%s %c" prompt translated)))) 982 ((and (not first) (eq translated ?\C-m)) 983 (setq done t)) 984 ((not first) 985 (setq unread-command-events (list char) 986 done t)) 987 (t (setq code translated 988 done t))) 989 (setq first nil)) 990 code)) 991 992(defun quoted-insert (arg) 993 "Read next input character and insert it. 994This is useful for inserting control characters. 995With argument, insert ARG copies of the character. 996 997If the first character you type after this command is an octal digit, 998you should type a sequence of octal digits that specify a character code. 999Any nondigit terminates the sequence. If the terminator is a RET, 1000it is discarded; any other terminator is used itself as input. 1001The variable `read-quoted-char-radix' specifies the radix for this feature; 1002set it to 10 or 16 to use decimal or hex instead of octal. 1003 1004In overwrite mode, this function inserts the character anyway, and 1005does not handle octal digits specially. This means that if you use 1006overwrite as your normal editing mode, you can use this function to 1007insert characters when necessary. 1008 1009In binary overwrite mode, this function does overwrite, and octal 1010digits are interpreted as a character code. This is intended to be 1011useful for editing binary files." 1012 (interactive "*p") 1013 (let* ((char 1014 ;; Avoid "obsolete" warnings for translation-table-for-input. 1015 (with-no-warnings 1016 (let (translation-table-for-input input-method-function) 1017 (if (or (not overwrite-mode) 1018 (eq overwrite-mode 'overwrite-mode-binary)) 1019 (read-quoted-char) 1020 (read-char)))))) 1021 ;; This used to assume character codes 0240 - 0377 stand for 1022 ;; characters in some single-byte character set, and converted them 1023 ;; to Emacs characters. But in 23.1 this feature is deprecated 1024 ;; in favor of inserting the corresponding Unicode characters. 1025 ;; (if (and enable-multibyte-characters 1026 ;; (>= char ?\240) 1027 ;; (<= char ?\377)) 1028 ;; (setq char (unibyte-char-to-multibyte char))) 1029 (unless (characterp char) 1030 (user-error "%s is not a valid character" 1031 (key-description (vector char)))) 1032 (if (> arg 0) 1033 (if (eq overwrite-mode 'overwrite-mode-binary) 1034 (delete-char arg))) 1035 (while (> arg 0) 1036 (insert-and-inherit char) 1037 (setq arg (1- arg))))) 1038 1039(defun forward-to-indentation (&optional arg) 1040 "Move forward ARG lines and position at first nonblank character." 1041 (interactive "^p") 1042 (forward-line (or arg 1)) 1043 (skip-chars-forward " \t")) 1044 1045(defun backward-to-indentation (&optional arg) 1046 "Move backward ARG lines and position at first nonblank character." 1047 (interactive "^p") 1048 (forward-line (- (or arg 1))) 1049 (skip-chars-forward " \t")) 1050 1051(defun back-to-indentation () 1052 "Move point to the first non-whitespace character on this line." 1053 (interactive "^") 1054 (beginning-of-line 1) 1055 (skip-syntax-forward " " (line-end-position)) 1056 ;; Move back over chars that have whitespace syntax but have the p flag. 1057 (backward-prefix-chars)) 1058 1059(defun fixup-whitespace () 1060 "Fixup white space between objects around point. 1061Leave one space or none, according to the context." 1062 (interactive "*") 1063 (save-excursion 1064 (delete-horizontal-space) 1065 (if (or (looking-at "^\\|$\\|\\s)") 1066 (save-excursion (forward-char -1) 1067 (looking-at "$\\|\\s(\\|\\s'"))) 1068 nil 1069 (insert ?\s)))) 1070 1071(defun delete-horizontal-space (&optional backward-only) 1072 "Delete all spaces and tabs around point. 1073If BACKWARD-ONLY is non-nil, delete them only before point." 1074 (interactive "*P") 1075 (let ((orig-pos (point))) 1076 (delete-region 1077 (if backward-only 1078 orig-pos 1079 (progn 1080 (skip-chars-forward " \t") 1081 (constrain-to-field nil orig-pos t))) 1082 (progn 1083 (skip-chars-backward " \t") 1084 (constrain-to-field nil orig-pos))))) 1085 1086(defun just-one-space (&optional n) 1087 "Delete all spaces and tabs around point, leaving one space (or N spaces). 1088If N is negative, delete newlines as well, leaving -N spaces. 1089See also `cycle-spacing'." 1090 (interactive "*p") 1091 (cycle-spacing n nil 'single-shot)) 1092 1093(defvar cycle-spacing--context nil 1094 "Store context used in consecutive calls to `cycle-spacing' command. 1095The first time `cycle-spacing' runs, it saves in this variable: 1096its N argument, the original point position, and the original spacing 1097around point.") 1098 1099(defun cycle-spacing (&optional n preserve-nl-back mode) 1100 "Manipulate whitespace around point in a smart way. 1101In interactive use, this function behaves differently in successive 1102consecutive calls. 1103 1104The first call in a sequence acts like `just-one-space'. 1105It deletes all spaces and tabs around point, leaving one space 1106\(or N spaces). N is the prefix argument. If N is negative, 1107it deletes newlines as well, leaving -N spaces. 1108\(If PRESERVE-NL-BACK is non-nil, it does not delete newlines before point.) 1109 1110The second call in a sequence deletes all spaces. 1111 1112The third call in a sequence restores the original whitespace (and point). 1113 1114If MODE is `single-shot', it performs only the first step in the sequence. 1115If MODE is `fast' and the first step would not result in any change 1116\(i.e., there are exactly (abs N) spaces around point), 1117the function goes straight to the second step. 1118 1119Repeatedly calling the function with different values of N starts a 1120new sequence each time." 1121 (interactive "*p") 1122 (let ((orig-pos (point)) 1123 (skip-characters (if (and n (< n 0)) " \t\n\r" " \t")) 1124 (num (abs (or n 1)))) 1125 (skip-chars-backward (if preserve-nl-back " \t" skip-characters)) 1126 (constrain-to-field nil orig-pos) 1127 (cond 1128 ;; Command run for the first time, single-shot mode or different argument 1129 ((or (eq 'single-shot mode) 1130 (not (equal last-command this-command)) 1131 (not cycle-spacing--context) 1132 (not (eq (car cycle-spacing--context) n))) 1133 (let* ((start (point)) 1134 (num (- num (skip-chars-forward " " (+ num (point))))) 1135 (mid (point)) 1136 (end (progn 1137 (skip-chars-forward skip-characters) 1138 (constrain-to-field nil orig-pos t)))) 1139 (setq cycle-spacing--context ;; Save for later. 1140 ;; Special handling for case where there was no space at all. 1141 (unless (= start end) 1142 (cons n (cons orig-pos (buffer-substring start (point)))))) 1143 ;; If this run causes no change in buffer content, delete all spaces, 1144 ;; otherwise delete all excess spaces. 1145 (delete-region (if (and (eq mode 'fast) (zerop num) (= mid end)) 1146 start mid) end) 1147 (insert (make-string num ?\s)))) 1148 1149 ;; Command run for the second time. 1150 ((not (equal orig-pos (point))) 1151 (delete-region (point) orig-pos)) 1152 1153 ;; Command run for the third time. 1154 (t 1155 (insert (cddr cycle-spacing--context)) 1156 (goto-char (cadr cycle-spacing--context)) 1157 (setq cycle-spacing--context nil))))) 1158 1159(defun beginning-of-buffer (&optional arg) 1160 "Move point to the beginning of the buffer. 1161With numeric arg N, put point N/10 of the way from the beginning. 1162If the buffer is narrowed, this command uses the beginning of the 1163accessible part of the buffer. 1164 1165Push mark at previous position, unless either a \\[universal-argument] prefix 1166is supplied, or Transient Mark mode is enabled and the mark is active." 1167 (declare (interactive-only "use `(goto-char (point-min))' instead.")) 1168 (interactive "^P") 1169 (or (consp arg) 1170 (region-active-p) 1171 (push-mark)) 1172 (let ((size (- (point-max) (point-min)))) 1173 (goto-char (if (and arg (not (consp arg))) 1174 (+ (point-min) 1 1175 (/ (* size (prefix-numeric-value arg)) 10)) 1176 (point-min)))) 1177 (if (and arg (not (consp arg))) (forward-line 1))) 1178 1179(defun end-of-buffer (&optional arg) 1180 "Move point to the end of the buffer. 1181With numeric arg N, put point N/10 of the way from the end. 1182If the buffer is narrowed, this command uses the end of the 1183accessible part of the buffer. 1184 1185Push mark at previous position, unless either a \\[universal-argument] prefix 1186is supplied, or Transient Mark mode is enabled and the mark is active." 1187 (declare (interactive-only "use `(goto-char (point-max))' instead.")) 1188 (interactive "^P") 1189 (or (consp arg) (region-active-p) (push-mark)) 1190 (let ((size (- (point-max) (point-min)))) 1191 (goto-char (if (and arg (not (consp arg))) 1192 (- (point-max) 1193 (/ (* size (prefix-numeric-value arg)) 10)) 1194 (point-max)))) 1195 ;; If we went to a place in the middle of the buffer, 1196 ;; adjust it to the beginning of a line. 1197 (cond ((and arg (not (consp arg))) (forward-line 1)) 1198 ((and (eq (current-buffer) (window-buffer)) 1199 (> (point) (window-end nil t))) 1200 ;; If the end of the buffer is not already on the screen, 1201 ;; then scroll specially to put it near, but not at, the bottom. 1202 (overlay-recenter (point)) 1203 ;; FIXME: Arguably if `scroll-conservatively' is set, then 1204 ;; we should pass -1 to `recenter'. 1205 (recenter (if (and scroll-minibuffer-conservatively 1206 (window-minibuffer-p)) 1207 -1 -3))))) 1208 1209(defcustom delete-active-region t 1210 "Whether single-char deletion commands delete an active region. 1211This has an effect only if Transient Mark mode is enabled, and 1212affects `delete-forward-char' and `delete-backward-char', though 1213not `delete-char'. 1214 1215If the value is the symbol `kill', the active region is killed 1216instead of deleted." 1217 :type '(choice (const :tag "Delete active region" t) 1218 (const :tag "Kill active region" kill) 1219 (const :tag "Do ordinary deletion" nil)) 1220 :group 'killing 1221 :version "24.1") 1222 1223(setq region-extract-function 1224 (lambda (method) 1225 (when (region-beginning) 1226 (cond 1227 ((eq method 'bounds) 1228 (list (cons (region-beginning) (region-end)))) 1229 ((eq method 'delete-only) 1230 (delete-region (region-beginning) (region-end))) 1231 (t 1232 (filter-buffer-substring (region-beginning) (region-end) method)))))) 1233 1234(defvar region-insert-function 1235 (lambda (lines) 1236 (let ((first t)) 1237 (while lines 1238 (or first 1239 (insert ?\n)) 1240 (insert-for-yank (car lines)) 1241 (setq lines (cdr lines) 1242 first nil)))) 1243 "Function to insert the region's content. 1244Called with one argument LINES. 1245Insert the region as a list of lines.") 1246 1247(defun delete-backward-char (n &optional killflag) 1248 "Delete the previous N characters (following if N is negative). 1249If Transient Mark mode is enabled, the mark is active, and N is 1, 1250delete the text in the region and deactivate the mark instead. 1251To disable this, set option `delete-active-region' to nil. 1252 1253Optional second arg KILLFLAG, if non-nil, means to kill (save in 1254kill ring) instead of delete. If called interactively, a numeric 1255prefix argument specifies N, and KILLFLAG is also set if a prefix 1256argument is used. 1257 1258When killing, the killed text is filtered by 1259`filter-buffer-substring' before it is saved in the kill ring, so 1260the actual saved text might be different from what was killed. 1261 1262In Overwrite mode, single character backward deletion may replace 1263tabs with spaces so as to back over columns, unless point is at 1264the end of the line." 1265 (declare (interactive-only delete-char)) 1266 (interactive "p\nP") 1267 (unless (integerp n) 1268 (signal 'wrong-type-argument (list 'integerp n))) 1269 (cond ((and (use-region-p) 1270 delete-active-region 1271 (= n 1)) 1272 ;; If a region is active, kill or delete it. 1273 (if (eq delete-active-region 'kill) 1274 (kill-region (region-beginning) (region-end) 'region) 1275 (funcall region-extract-function 'delete-only))) 1276 ;; In Overwrite mode, maybe untabify while deleting 1277 ((null (or (null overwrite-mode) 1278 (<= n 0) 1279 (memq (char-before) '(?\t ?\n)) 1280 (eobp) 1281 (eq (char-after) ?\n))) 1282 (let ((ocol (current-column))) 1283 (delete-char (- n) killflag) 1284 (save-excursion 1285 (insert-char ?\s (- ocol (current-column)) nil)))) 1286 ;; Otherwise, do simple deletion. 1287 (t (delete-char (- n) killflag)))) 1288 1289(defun delete-forward-char (n &optional killflag) 1290 "Delete the following N characters (previous if N is negative). 1291If Transient Mark mode is enabled, the mark is active, and N is 1, 1292delete the text in the region and deactivate the mark instead. 1293To disable this, set variable `delete-active-region' to nil. 1294 1295Optional second arg KILLFLAG non-nil means to kill (save in kill 1296ring) instead of delete. If called interactively, a numeric 1297prefix argument specifies N, and KILLFLAG is also set if a prefix 1298argument is used. 1299 1300When killing, the killed text is filtered by 1301`filter-buffer-substring' before it is saved in the kill ring, so 1302the actual saved text might be different from what was killed." 1303 (declare (interactive-only delete-char)) 1304 (interactive "p\nP") 1305 (unless (integerp n) 1306 (signal 'wrong-type-argument (list 'integerp n))) 1307 (cond ((and (use-region-p) 1308 delete-active-region 1309 (= n 1)) 1310 ;; If a region is active, kill or delete it. 1311 (if (eq delete-active-region 'kill) 1312 (kill-region (region-beginning) (region-end) 'region) 1313 (funcall region-extract-function 'delete-only))) 1314 1315 ;; Otherwise, do simple deletion. 1316 (t (delete-char n killflag)))) 1317 1318(defun mark-whole-buffer () 1319 "Put point at beginning and mark at end of buffer. 1320Also push mark at point before pushing mark at end of buffer. 1321If narrowing is in effect, uses only the accessible part of the buffer. 1322You probably should not use this function in Lisp programs; 1323it is usually a mistake for a Lisp function to use any subroutine 1324that uses or sets the mark." 1325 (declare (interactive-only t)) 1326 (interactive) 1327 (push-mark) 1328 (push-mark (point-max) nil t) 1329 ;; This is really `point-min' in most cases, but if we're in the 1330 ;; minibuffer, this is at the end of the prompt. 1331 (goto-char (minibuffer-prompt-end))) 1332 1333;; Counting lines, one way or another. 1334 1335(defcustom goto-line-history-local nil 1336 "If this option is nil, `goto-line-history' is shared between all buffers. 1337If it is non-nil, each buffer has its own value of this history list. 1338 1339Note that on changing from non-nil to nil, the former contents of 1340`goto-line-history' for each buffer are discarded on use of 1341`goto-line' in that buffer." 1342 :group 'editing 1343 :type 'boolean 1344 :safe #'booleanp 1345 :version "28.1") 1346 1347(defvar goto-line-history nil 1348 "History of values entered with `goto-line'.") 1349 1350(defun goto-line-read-args (&optional relative) 1351 "Read arguments for `goto-line' related commands." 1352 (if (and current-prefix-arg (not (consp current-prefix-arg))) 1353 (list (prefix-numeric-value current-prefix-arg)) 1354 ;; Look for a default, a number in the buffer at point. 1355 (let* ((number (number-at-point)) 1356 (default (and (natnump number) number)) 1357 ;; Decide if we're switching buffers. 1358 (buffer 1359 (if (consp current-prefix-arg) 1360 (other-buffer (current-buffer) t))) 1361 (buffer-prompt 1362 (if buffer 1363 (concat " in " (buffer-name buffer)) 1364 ""))) 1365 ;; Has the buffer locality of `goto-line-history' changed? 1366 (cond ((and goto-line-history-local (not (local-variable-p 'goto-line-history))) 1367 (make-local-variable 'goto-line-history)) 1368 ((and (not goto-line-history-local) (local-variable-p 'goto-line-history)) 1369 (kill-local-variable 'goto-line-history))) 1370 ;; Read the argument, offering that number (if any) as default. 1371 (list (read-number (format "Goto%s line%s: " 1372 (if (buffer-narrowed-p) 1373 (if relative " relative" " absolute") 1374 "") 1375 buffer-prompt) 1376 (list default (if (or relative (not (buffer-narrowed-p))) 1377 (line-number-at-pos) 1378 (save-restriction 1379 (widen) 1380 (line-number-at-pos)))) 1381 'goto-line-history) 1382 buffer)))) 1383 1384(defun goto-line (line &optional buffer relative) 1385 "Go to LINE, counting from line 1 at beginning of buffer. 1386If called interactively, a numeric prefix argument specifies 1387LINE; without a numeric prefix argument, read LINE from the 1388minibuffer. 1389 1390If optional argument BUFFER is non-nil, switch to that buffer and 1391move to line LINE there. If called interactively with \\[universal-argument] 1392as argument, BUFFER is the most recently selected other buffer. 1393 1394If optional argument RELATIVE is non-nil, counting starts at the beginning 1395of the accessible portion of the (potentially narrowed) buffer. 1396 1397If the variable `widen-automatically' is non-nil, cancel narrowing and 1398leave all lines accessible. If `widen-automatically' is nil, just move 1399point to the edge of visible portion and don't change the buffer bounds. 1400 1401Prior to moving point, this function sets the mark (without 1402activating it), unless Transient Mark mode is enabled and the 1403mark is already active. 1404 1405This function is usually the wrong thing to use in a Lisp program. 1406What you probably want instead is something like: 1407 (goto-char (point-min)) 1408 (forward-line (1- N)) 1409If at all possible, an even better solution is to use char counts 1410rather than line counts." 1411 (declare (interactive-only forward-line)) 1412 (interactive (goto-line-read-args)) 1413 ;; Switch to the desired buffer, one way or another. 1414 (if buffer 1415 (let ((window (get-buffer-window buffer))) 1416 (if window (select-window window) 1417 (switch-to-buffer-other-window buffer)))) 1418 ;; Leave mark at previous position 1419 (or (region-active-p) (push-mark)) 1420 ;; Move to the specified line number in that buffer. 1421 (let ((pos (save-restriction 1422 (unless relative (widen)) 1423 (goto-char (point-min)) 1424 (if (eq selective-display t) 1425 (re-search-forward "[\n\C-m]" nil 'end (1- line)) 1426 (forward-line (1- line))) 1427 (point)))) 1428 (when (and (not relative) 1429 (buffer-narrowed-p) 1430 widen-automatically 1431 ;; Position is outside narrowed part of buffer 1432 (or (> (point-min) pos) (> pos (point-max)))) 1433 (widen)) 1434 (goto-char pos))) 1435 1436(defun goto-line-relative (line &optional buffer) 1437 "Go to LINE, counting from line at (point-min). 1438The line number is relative to the accessible portion of the narrowed 1439buffer. The argument BUFFER is the same as in the function `goto-line'." 1440 (declare (interactive-only forward-line)) 1441 (interactive (goto-line-read-args t)) 1442 (with-suppressed-warnings ((interactive-only goto-line)) 1443 (goto-line line buffer t))) 1444 1445(defun count-words-region (start end &optional arg) 1446 "Count the number of words in the region. 1447If called interactively, print a message reporting the number of 1448lines, words, and characters in the region (whether or not the 1449region is active); with prefix ARG, report for the entire buffer 1450rather than the region. 1451 1452If called from Lisp, return the number of words between positions 1453START and END." 1454 (interactive (if current-prefix-arg 1455 (list nil nil current-prefix-arg) 1456 (list (region-beginning) (region-end) nil))) 1457 (cond ((not (called-interactively-p 'any)) 1458 (count-words start end)) 1459 (arg 1460 (count-words--buffer-message)) 1461 (t 1462 (count-words--message "Region" start end)))) 1463 1464(defun count-words (start end) 1465 "Count words between START and END. 1466If called interactively, START and END are normally the start and 1467end of the buffer; but if the region is active, START and END are 1468the start and end of the region. Print a message reporting the 1469number of lines, words, and chars. 1470 1471If called from Lisp, return the number of words between START and 1472END, without printing any message." 1473 (interactive (list nil nil)) 1474 (cond ((not (called-interactively-p 'any)) 1475 (let ((words 0) 1476 ;; Count across field boundaries. (Bug#41761) 1477 (inhibit-field-text-motion t)) 1478 (save-excursion 1479 (save-restriction 1480 (narrow-to-region start end) 1481 (goto-char (point-min)) 1482 (while (forward-word-strictly 1) 1483 (setq words (1+ words))))) 1484 words)) 1485 ((use-region-p) 1486 (call-interactively 'count-words-region)) 1487 (t 1488 (count-words--buffer-message)))) 1489 1490(defun count-words--buffer-message () 1491 (count-words--message 1492 (if (buffer-narrowed-p) "Narrowed part of buffer" "Buffer") 1493 (point-min) (point-max))) 1494 1495(defun count-words--message (str start end) 1496 (let ((lines (count-lines start end)) 1497 (words (count-words start end)) 1498 (chars (- end start))) 1499 (message "%s has %d line%s, %d word%s, and %d character%s." 1500 str 1501 lines (if (= lines 1) "" "s") 1502 words (if (= words 1) "" "s") 1503 chars (if (= chars 1) "" "s")))) 1504 1505(define-obsolete-function-alias 'count-lines-region 'count-words-region "24.1") 1506 1507(defun what-line () 1508 "Print the current buffer line number and narrowed line number of point." 1509 (interactive) 1510 (let ((start (point-min)) 1511 (n (line-number-at-pos))) 1512 (if (= start 1) 1513 (message "Line %d" n) 1514 (save-excursion 1515 (save-restriction 1516 (widen) 1517 (message "line %d (narrowed line %d)" 1518 (+ n (line-number-at-pos start) -1) n)))))) 1519 1520(defun count-lines (start end &optional ignore-invisible-lines) 1521 "Return number of lines between START and END. 1522This is usually the number of newlines between them, but can be 1523one more if START is not equal to END and the greater of them is 1524not at the start of a line. 1525 1526When IGNORE-INVISIBLE-LINES is non-nil, invisible lines are not 1527included in the count." 1528 (save-excursion 1529 (save-restriction 1530 (narrow-to-region start end) 1531 (cond ((and (not ignore-invisible-lines) 1532 (eq selective-display t)) 1533 (goto-char (point-min)) 1534 (save-match-data 1535 (let ((done 0)) 1536 (while (re-search-forward "\n\\|\r[^\n]" nil t 40) 1537 (setq done (+ 40 done))) 1538 (while (re-search-forward "\n\\|\r[^\n]" nil t 1) 1539 (setq done (+ 1 done))) 1540 (goto-char (point-max)) 1541 (if (and (/= start end) 1542 (not (bolp))) 1543 (1+ done) 1544 done)))) 1545 (ignore-invisible-lines 1546 (goto-char (point-min)) 1547 (save-match-data 1548 (- (buffer-size) 1549 (forward-line (buffer-size)) 1550 (let ((invisible-count 0) 1551 prop) 1552 (goto-char (point-min)) 1553 (while (re-search-forward "\n\\|\r[^\n]" nil t) 1554 (setq prop (get-char-property (1- (point)) 'invisible)) 1555 (if (if (eq buffer-invisibility-spec t) 1556 prop 1557 (or (memq prop buffer-invisibility-spec) 1558 (assq prop buffer-invisibility-spec))) 1559 (setq invisible-count (1+ invisible-count)))) 1560 invisible-count)))) 1561 (t 1562 (goto-char (point-max)) 1563 (if (bolp) 1564 (1- (line-number-at-pos)) 1565 (line-number-at-pos))))))) 1566 1567(defcustom what-cursor-show-names nil 1568 "Whether to show character names in `what-cursor-position'." 1569 :type 'boolean 1570 :version "27.1" 1571 :group 'editing-basics) 1572 1573(defun what-cursor-position (&optional detail) 1574 "Print info on cursor position (on screen and within buffer). 1575Also describe the character after point, and give its character 1576code in octal, decimal and hex. If `what-cursor-show-names' is 1577non-nil, additionally show the name of the character. 1578 1579For a non-ASCII multibyte character, also give its encoding in the 1580buffer's selected coding system if the coding system encodes the 1581character safely. If the character is encoded into one byte, that 1582code is shown in hex. If the character is encoded into more than one 1583byte, just \"...\" is shown. 1584 1585In addition, with prefix argument, show details about that character 1586in *Help* buffer. See also the command `describe-char'." 1587 (interactive "P") 1588 (let* ((char (following-char)) 1589 (char-name (and what-cursor-show-names 1590 (or (get-char-code-property char 'name) 1591 (get-char-code-property char 'old-name)))) 1592 (char-name-fmt (if char-name 1593 (format ", %s" char-name) 1594 "")) 1595 (bidi-fixer 1596 ;; If the character is one of LRE, LRO, RLE, RLO, it will 1597 ;; start a directional embedding, which could completely 1598 ;; disrupt the rest of the line (e.g., RLO will display the 1599 ;; rest of the line right-to-left). So we put an invisible 1600 ;; PDF character after these characters, to end the 1601 ;; embedding, which eliminates any effects on the rest of 1602 ;; the line. For RLE and RLO we also append an invisible 1603 ;; LRM, to avoid reordering the following numerical 1604 ;; characters. For LRI/RLI/FSI we append a PDI. 1605 (cond ((memq char '(?\x202a ?\x202d)) 1606 (propertize (string ?\x202c) 'invisible t)) 1607 ((memq char '(?\x202b ?\x202e)) 1608 (propertize (string ?\x202c ?\x200e) 'invisible t)) 1609 ((memq char '(?\x2066 ?\x2067 ?\x2068)) 1610 (propertize (string ?\x2069) 'invisible t)) 1611 ;; Strong right-to-left characters cause reordering of 1612 ;; the following numerical characters which show the 1613 ;; codepoint, so append LRM to countermand that. 1614 ((memq (get-char-code-property char 'bidi-class) '(R AL)) 1615 (propertize (string ?\x200e) 'invisible t)) 1616 (t 1617 ""))) 1618 (beg (point-min)) 1619 (end (point-max)) 1620 (pos (point)) 1621 (total (buffer-size)) 1622 (percent (round (* 100.0 (1- pos)) (max 1 total))) 1623 (hscroll (if (= (window-hscroll) 0) 1624 "" 1625 (format " Hscroll=%d" (window-hscroll)))) 1626 (col (current-column))) 1627 (if (= pos end) 1628 (if (or (/= beg 1) (/= end (1+ total))) 1629 (message "point=%d of %d (%d%%) <%d-%d> column=%d%s" 1630 pos total percent beg end col hscroll) 1631 (message "point=%d of %d (EOB) column=%d%s" 1632 pos total col hscroll)) 1633 (let ((coding buffer-file-coding-system) 1634 encoded encoding-msg display-prop under-display) 1635 (if (or (not coding) 1636 (eq (coding-system-type coding) t)) 1637 (setq coding (or (default-value 'buffer-file-coding-system) 1638 ;; A nil value of `buffer-file-coding-system' 1639 ;; means "no conversion" which means each byte 1640 ;; is a char and vice versa. 1641 'binary))) 1642 (if (eq (char-charset char) 'eight-bit) 1643 (setq encoding-msg 1644 (format "(%d, #o%o, #x%x%s, raw-byte)" char char char char-name-fmt)) 1645 ;; Check if the character is displayed with some `display' 1646 ;; text property. In that case, set under-display to the 1647 ;; buffer substring covered by that property. 1648 (setq display-prop (get-char-property pos 'display)) 1649 (if display-prop 1650 (let ((to (or (next-single-char-property-change pos 'display) 1651 (point-max)))) 1652 (if (< to (+ pos 4)) 1653 (setq under-display "") 1654 (setq under-display "..." 1655 to (+ pos 4))) 1656 (setq under-display 1657 (concat (buffer-substring-no-properties pos to) 1658 under-display))) 1659 (setq encoded (and (>= char 128) (encode-coding-char char coding)))) 1660 (setq encoding-msg 1661 (if display-prop 1662 (if (not (stringp display-prop)) 1663 (format "(%d, #o%o, #x%x%s, part of display \"%s\")" 1664 char char char char-name-fmt under-display) 1665 (format "(%d, #o%o, #x%x%s, part of display \"%s\"->\"%s\")" 1666 char char char char-name-fmt under-display display-prop)) 1667 (if encoded 1668 (format "(%d, #o%o, #x%x%s, file %s)" 1669 char char char char-name-fmt 1670 (if (> (length encoded) 1) 1671 "..." 1672 (encoded-string-description encoded coding))) 1673 (format "(%d, #o%o, #x%x%s)" char char char char-name-fmt))))) 1674 (if detail 1675 ;; We show the detailed information about CHAR. 1676 (describe-char (point))) 1677 (if (or (/= beg 1) (/= end (1+ total))) 1678 (message "Char: %s%s %s point=%d of %d (%d%%) <%d-%d> column=%d%s" 1679 (if (< char 256) 1680 (single-key-description char) 1681 (buffer-substring-no-properties (point) (1+ (point)))) 1682 bidi-fixer 1683 encoding-msg pos total percent beg end col hscroll) 1684 (message "Char: %s%s %s point=%d of %d (%d%%) column=%d%s" 1685 (if enable-multibyte-characters 1686 (if (< char 128) 1687 (single-key-description char) 1688 (buffer-substring-no-properties (point) (1+ (point)))) 1689 (single-key-description char)) 1690 bidi-fixer encoding-msg pos total percent col hscroll)))))) 1691 1692;; Initialize read-expression-map. It is defined at C level. 1693(defvar read-expression-map 1694 (let ((m (make-sparse-keymap))) 1695 (define-key m "\M-\t" 'completion-at-point) 1696 ;; Might as well bind TAB to completion, since inserting a TAB char is 1697 ;; much too rarely useful. 1698 (define-key m "\t" 'completion-at-point) 1699 (define-key m "\r" 'read--expression-try-read) 1700 (define-key m "\n" 'read--expression-try-read) 1701 (define-key m "\M-g\M-c" 'read-expression-switch-to-completions) 1702 (set-keymap-parent m minibuffer-local-map) 1703 m)) 1704 1705(defun read-minibuffer (prompt &optional initial-contents) 1706 "Return a Lisp object read using the minibuffer, unevaluated. 1707Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS 1708is a string to insert in the minibuffer before reading. 1709\(INITIAL-CONTENTS can also be a cons of a string and an integer. 1710Such arguments are used as in `read-from-minibuffer'.)" 1711 ;; Used for interactive spec `x'. 1712 (read-from-minibuffer prompt initial-contents minibuffer-local-map 1713 t 'minibuffer-history)) 1714 1715(defun eval-minibuffer (prompt &optional initial-contents) 1716 "Return value of Lisp expression read using the minibuffer. 1717Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS 1718is a string to insert in the minibuffer before reading. 1719\(INITIAL-CONTENTS can also be a cons of a string and an integer. 1720Such arguments are used as in `read-from-minibuffer'.)" 1721 ;; Used for interactive spec `X'. 1722 (eval (read--expression prompt initial-contents))) 1723 1724(defvar minibuffer-completing-symbol nil 1725 "Non-nil means completing a Lisp symbol in the minibuffer.") 1726(make-obsolete-variable 'minibuffer-completing-symbol nil "24.1" 'get) 1727 1728(defvar minibuffer-default nil 1729 "The current default value or list of default values in the minibuffer. 1730The functions `read-from-minibuffer' and `completing-read' bind 1731this variable locally.") 1732 1733(defcustom eval-expression-print-level 4 1734 "Value for `print-level' while printing value in `eval-expression'. 1735A value of nil means no limit." 1736 :group 'lisp 1737 :type '(choice (const :tag "No Limit" nil) integer) 1738 :version "21.1") 1739 1740(defcustom eval-expression-print-length 12 1741 "Value for `print-length' while printing value in `eval-expression'. 1742A value of nil means no limit." 1743 :group 'lisp 1744 :type '(choice (const :tag "No Limit" nil) integer) 1745 :version "21.1") 1746 1747(defcustom eval-expression-debug-on-error t 1748 "If non-nil set `debug-on-error' to t in `eval-expression'. 1749If nil, don't change the value of `debug-on-error'." 1750 :group 'lisp 1751 :type 'boolean 1752 :version "21.1") 1753 1754(defcustom eval-expression-print-maximum-character 127 1755 "The largest integer that will be displayed as a character. 1756This affects printing by `eval-expression' (via 1757`eval-expression-print-format')." 1758 :group 'lisp 1759 :type `(choice (const :tag "ASCII characters" 127) 1760 (const :tag "All characters" ,(max-char)) 1761 (integer :tag "Max codepoint to display as character")) 1762 :version "26.1") 1763 1764(defun eval-expression-print-format (value) 1765 "If VALUE is an integer, return a specially formatted string. 1766This string will typically look like \" (#o1, #x1, ?\\C-a)\". 1767If VALUE is not an integer, return nil. 1768This function is used by commands like `eval-expression' that 1769display the result of expression evaluation." 1770 (when (integerp value) 1771 (let ((char-string 1772 (and (characterp value) 1773 (<= value eval-expression-print-maximum-character) 1774 (char-displayable-p value) 1775 (prin1-char value)))) 1776 (if char-string 1777 (format " (#o%o, #x%x, %s)" value value char-string) 1778 (format " (#o%o, #x%x)" value value))))) 1779 1780(defvar eval-expression-minibuffer-setup-hook nil 1781 "Hook run by `eval-expression' when entering the minibuffer.") 1782 1783(defun read--expression (prompt &optional initial-contents) 1784 "Read an Emacs Lisp expression from the minibuffer. 1785 1786PROMPT and optional argument INITIAL-CONTENTS do the same as in 1787function `read-from-minibuffer'." 1788 (let ((minibuffer-completing-symbol t)) 1789 (minibuffer-with-setup-hook 1790 (lambda () 1791 ;; FIXME: instead of just applying the syntax table, maybe 1792 ;; use a special major mode tailored to reading Lisp 1793 ;; expressions from the minibuffer? (`emacs-lisp-mode' 1794 ;; doesn't preserve the necessary keybindings.) 1795 (set-syntax-table emacs-lisp-mode-syntax-table) 1796 (add-hook 'completion-at-point-functions 1797 #'elisp-completion-at-point nil t) 1798 (run-hooks 'eval-expression-minibuffer-setup-hook)) 1799 (read-from-minibuffer prompt initial-contents 1800 read-expression-map t 1801 'read-expression-history)))) 1802 1803(defun read--expression-try-read () 1804 "Try to read an Emacs Lisp expression in the minibuffer. 1805 1806Exit the minibuffer if successful, else report the error to the 1807user and move point to the location of the error. If point is 1808not already at the location of the error, push a mark before 1809moving point." 1810 (interactive) 1811 (unless (> (minibuffer-depth) 0) 1812 (error "Minibuffer must be active")) 1813 (if (let* ((contents (minibuffer-contents)) 1814 (error-point nil)) 1815 (with-temp-buffer 1816 (condition-case err 1817 (progn 1818 (insert contents) 1819 (goto-char (point-min)) 1820 ;; `read' will signal errors like "End of file during 1821 ;; parsing" and "Invalid read syntax". 1822 (read (current-buffer)) 1823 ;; Since `read' does not signal the "Trailing garbage 1824 ;; following expression" error, we check for trailing 1825 ;; garbage ourselves. 1826 (or (progn 1827 ;; This check is similar to what `string_to_object' 1828 ;; does in minibuf.c. 1829 (skip-chars-forward " \t\n") 1830 (= (point) (point-max))) 1831 (error "Trailing garbage following expression"))) 1832 (error 1833 (setq error-point (+ (length (minibuffer-prompt)) (point))) 1834 (with-current-buffer (window-buffer (minibuffer-window)) 1835 (unless (= (point) error-point) 1836 (push-mark)) 1837 (goto-char error-point) 1838 (minibuffer-message (error-message-string err))) 1839 nil)))) 1840 (exit-minibuffer))) 1841 1842(defun eval-expression-get-print-arguments (prefix-argument) 1843 "Get arguments for commands that print an expression result. 1844Returns a list (INSERT-VALUE NO-TRUNCATE CHAR-PRINT-LIMIT) based 1845on PREFIX-ARGUMENT. This function determines the interpretation 1846of the prefix argument for `eval-expression' and 1847`eval-last-sexp'." 1848 (let ((num (prefix-numeric-value prefix-argument))) 1849 (list (not (memq prefix-argument '(- nil))) 1850 (= num 0) 1851 (cond ((not (memq prefix-argument '(0 -1 - nil))) nil) 1852 ((= num -1) most-positive-fixnum) 1853 (t eval-expression-print-maximum-character))))) 1854 1855;; We define this, rather than making `eval' interactive, 1856;; for the sake of completion of names like eval-region, eval-buffer. 1857(defun eval-expression (exp &optional insert-value no-truncate char-print-limit) 1858 "Evaluate EXP and print value in the echo area. 1859When called interactively, read an Emacs Lisp expression and 1860evaluate it. Value is also consed on to front of the variable 1861`values'. Optional argument INSERT-VALUE non-nil (interactively, 1862with a non `-' prefix argument) means insert the result into the 1863current buffer instead of printing it in the echo area. 1864 1865Normally, this function truncates long output according to the 1866value of the variables `eval-expression-print-length' and 1867`eval-expression-print-level'. When NO-TRUNCATE is 1868non-nil (interactively, with a prefix argument of zero), however, 1869there is no such truncation. 1870 1871If the resulting value is an integer, and CHAR-PRINT-LIMIT is 1872non-nil (interactively, unless given a non-zero prefix argument) 1873it will be printed in several additional formats (octal, 1874hexadecimal, and character). The character format is used only 1875if the value is below CHAR-PRINT-LIMIT (interactively, if the 1876prefix argument is -1 or the value doesn't exceed 1877`eval-expression-print-maximum-character'). 1878 1879Runs the hook `eval-expression-minibuffer-setup-hook' on entering the 1880minibuffer. 1881 1882If `eval-expression-debug-on-error' is non-nil, which is the default, 1883this command arranges for all errors to enter the debugger." 1884 (interactive 1885 (cons (read--expression "Eval: ") 1886 (eval-expression-get-print-arguments current-prefix-arg))) 1887 1888 (let (result) 1889 (if (null eval-expression-debug-on-error) 1890 (setq result 1891 (values--store-value 1892 (eval (let ((lexical-binding t)) (macroexpand-all exp)) t))) 1893 (let ((old-value (make-symbol "t")) new-value) 1894 ;; Bind debug-on-error to something unique so that we can 1895 ;; detect when evalled code changes it. 1896 (let ((debug-on-error old-value)) 1897 (setq result 1898 (values--store-value 1899 (eval (let ((lexical-binding t)) (macroexpand-all exp)) t))) 1900 (setq new-value debug-on-error)) 1901 ;; If evalled code has changed the value of debug-on-error, 1902 ;; propagate that change to the global binding. 1903 (unless (eq old-value new-value) 1904 (setq debug-on-error new-value)))) 1905 1906 (let ((print-length (unless no-truncate eval-expression-print-length)) 1907 (print-level (unless no-truncate eval-expression-print-level)) 1908 (eval-expression-print-maximum-character char-print-limit) 1909 (deactivate-mark)) 1910 (let ((out (if insert-value (current-buffer) t))) 1911 (prog1 1912 (prin1 result out) 1913 (let ((str (and char-print-limit 1914 (eval-expression-print-format result)))) 1915 (when str (princ str out)))))))) 1916 1917(defun edit-and-eval-command (prompt command) 1918 "Prompting with PROMPT, let user edit COMMAND and eval result. 1919COMMAND is a Lisp expression. Let user edit that expression in 1920the minibuffer, then read and evaluate the result." 1921 (let ((command 1922 (let ((print-level nil) 1923 (minibuffer-history-sexp-flag (1+ (minibuffer-depth)))) 1924 (unwind-protect 1925 (read-from-minibuffer prompt 1926 (prin1-to-string command) 1927 read-expression-map t 1928 'command-history) 1929 ;; If command was added to command-history as a string, 1930 ;; get rid of that. We want only evaluable expressions there. 1931 (when (stringp (car command-history)) 1932 (pop command-history)))))) 1933 1934 (add-to-history 'command-history command) 1935 (eval command))) 1936 1937(defun repeat-complex-command (arg) 1938 "Edit and re-evaluate last complex command, or ARGth from last. 1939A complex command is one that used the minibuffer. 1940The command is placed in the minibuffer as a Lisp form for editing. 1941The result is executed, repeating the command as changed. 1942If the command has been changed or is not the most recent previous 1943command it is added to the front of the command history. 1944You can use the minibuffer history commands \ 1945\\<minibuffer-local-map>\\[next-history-element] and \\[previous-history-element] 1946to get different commands to edit and resubmit." 1947 (interactive "p") 1948 (let ((elt (nth (1- arg) command-history)) 1949 newcmd) 1950 (if elt 1951 (progn 1952 (setq newcmd 1953 (let ((print-level nil) 1954 (minibuffer-history-position arg) 1955 (minibuffer-history-sexp-flag (1+ (minibuffer-depth)))) 1956 (unwind-protect 1957 (read-from-minibuffer 1958 "Redo: " (prin1-to-string elt) read-expression-map t 1959 (cons 'command-history arg)) 1960 1961 ;; If command was added to command-history as a 1962 ;; string, get rid of that. We want only 1963 ;; evaluable expressions there. 1964 (when (stringp (car command-history)) 1965 (pop command-history))))) 1966 1967 (add-to-history 'command-history newcmd) 1968 (apply #'funcall-interactively 1969 (car newcmd) 1970 (mapcar (lambda (e) (eval e t)) (cdr newcmd)))) 1971 (if command-history 1972 (error "Argument %d is beyond length of command history" arg) 1973 (error "There are no previous complex commands to repeat"))))) 1974 1975 1976(defvar extended-command-history nil) 1977(defvar execute-extended-command--last-typed nil) 1978 1979(defcustom read-extended-command-predicate nil 1980 "Predicate to use to determine which commands to include when completing. 1981If it's nil, include all the commands. 1982If it's a function, it will be called with two parameters: the 1983symbol of the command and a buffer. The predicate should return 1984non-nil if the command should be present when doing `M-x TAB' 1985in that buffer." 1986 :version "28.1" 1987 :group 'completion 1988 :type '(choice (const :tag "Don't exclude any commands" nil) 1989 (const :tag "Exclude commands irrelevant to current buffer's mode" 1990 command-completion-default-include-p) 1991 (function :tag "Other function"))) 1992 1993(defun read-extended-command () 1994 "Read command name to invoke in `execute-extended-command'. 1995This function uses the `read-extended-command-predicate' user option." 1996 (let ((buffer (current-buffer))) 1997 (minibuffer-with-setup-hook 1998 (lambda () 1999 (add-hook 'post-self-insert-hook 2000 (lambda () 2001 (setq execute-extended-command--last-typed 2002 (minibuffer-contents))) 2003 nil 'local) 2004 (setq-local minibuffer-default-add-function 2005 (lambda () 2006 ;; Get a command name at point in the original buffer 2007 ;; to propose it after M-n. 2008 (let ((def 2009 (with-current-buffer 2010 (window-buffer (minibuffer-selected-window)) 2011 (and (commandp (function-called-at-point)) 2012 (format 2013 "%S" (function-called-at-point))))) 2014 (all (sort (minibuffer-default-add-completions) 2015 #'string<))) 2016 (if def 2017 (cons def (delete def all)) 2018 all))))) 2019 ;; Read a string, completing from and restricting to the set of 2020 ;; all defined commands. Don't provide any initial input. 2021 ;; Save the command read on the extended-command history list. 2022 (completing-read 2023 (concat (cond 2024 ((eq current-prefix-arg '-) "- ") 2025 ((and (consp current-prefix-arg) 2026 (eq (car current-prefix-arg) 4)) 2027 "C-u ") 2028 ((and (consp current-prefix-arg) 2029 (integerp (car current-prefix-arg))) 2030 (format "%d " (car current-prefix-arg))) 2031 ((integerp current-prefix-arg) 2032 (format "%d " current-prefix-arg))) 2033 ;; This isn't strictly correct if `execute-extended-command' 2034 ;; is bound to anything else (e.g. [menu]). 2035 ;; It could use (key-description (this-single-command-keys)), 2036 ;; but actually a prompt other than "M-x" would be confusing, 2037 ;; because "M-x" is a well-known prompt to read a command 2038 ;; and it serves as a shorthand for "Extended command: ". 2039 (if (memq 'shift (event-modifiers last-command-event)) 2040 "M-X " 2041 "M-x ")) 2042 (lambda (string pred action) 2043 (if (and suggest-key-bindings (eq action 'metadata)) 2044 '(metadata 2045 (affixation-function . read-extended-command--affixation) 2046 (category . command)) 2047 (let ((pred 2048 (if (memq action '(nil t)) 2049 ;; Exclude from completions obsolete commands 2050 ;; lacking a `current-name', or where `when' is 2051 ;; not the current major version. 2052 (lambda (sym) 2053 (let ((obsolete (get sym 'byte-obsolete-info))) 2054 (and (funcall pred sym) 2055 (or (equal string (symbol-name sym)) 2056 (not obsolete) 2057 (and 2058 ;; Has a current-name. 2059 (functionp (car obsolete)) 2060 ;; when >= emacs-major-version 2061 (condition-case nil 2062 (>= (car (version-to-list 2063 (caddr obsolete))) 2064 emacs-major-version) 2065 ;; If the obsoletion version isn't 2066 ;; valid, include the command. 2067 (error t))))))) 2068 pred))) 2069 (complete-with-action action obarray string pred)))) 2070 (lambda (sym) 2071 (and (commandp sym) 2072 (cond ((null read-extended-command-predicate)) 2073 ((functionp read-extended-command-predicate) 2074 ;; Don't let bugs break M-x completion; interpret 2075 ;; them as the absence of a predicate. 2076 (condition-case-unless-debug err 2077 (funcall read-extended-command-predicate sym buffer) 2078 (error (message "read-extended-command-predicate: %s: %s" 2079 sym (error-message-string err)))))))) 2080 t nil 'extended-command-history)))) 2081 2082(defun command-completion-using-modes-p (symbol buffer) 2083 "Say whether SYMBOL has been marked as a mode-specific command in BUFFER." 2084 ;; Check the modes. 2085 (let ((modes (command-modes symbol))) 2086 ;; Common fast case: Just a single mode. 2087 (if (null (cdr modes)) 2088 (or (provided-mode-derived-p 2089 (buffer-local-value 'major-mode buffer) (car modes)) 2090 (memq (car modes) 2091 (buffer-local-value 'local-minor-modes buffer)) 2092 (memq (car modes) global-minor-modes)) 2093 ;; Uncommon case: Multiple modes. 2094 (command-completion-with-modes-p modes buffer)))) 2095 2096(defun command-completion-default-include-p (symbol buffer) 2097 "Say whether SYMBOL should be offered as a completion. 2098If there's a `completion-predicate' for SYMBOL, the result from 2099calling that predicate is called. If there isn't one, this 2100predicate is true if the command SYMBOL is applicable to the 2101major mode in BUFFER, or any of the active minor modes in 2102BUFFER." 2103 (if (get symbol 'completion-predicate) 2104 ;; An explicit completion predicate takes precedence. 2105 (funcall (get symbol 'completion-predicate) symbol buffer) 2106 (or (null (command-modes symbol)) 2107 (command-completion-using-modes-p symbol buffer)))) 2108 2109(defun command-completion-with-modes-p (modes buffer) 2110 "Say whether MODES are in action in BUFFER. 2111This is the case if either the major mode is derived from one of MODES, 2112or (if one of MODES is a minor mode), if it is switched on in BUFFER." 2113 (or (apply #'provided-mode-derived-p 2114 (buffer-local-value 'major-mode buffer) 2115 modes) 2116 ;; It's a minor mode. 2117 (seq-intersection modes 2118 (buffer-local-value 'local-minor-modes buffer) 2119 #'eq) 2120 (seq-intersection modes global-minor-modes #'eq))) 2121 2122(defun command-completion-button-p (category buffer) 2123 "Return non-nil if there's a button of CATEGORY at point in BUFFER." 2124 (with-current-buffer buffer 2125 (and (get-text-property (point) 'button) 2126 (eq (get-text-property (point) 'category) category)))) 2127 2128(defun read-extended-command--affixation (command-names) 2129 (with-selected-window (or (minibuffer-selected-window) (selected-window)) 2130 (mapcar 2131 (lambda (command-name) 2132 (let* ((fun (and (stringp command-name) (intern-soft command-name))) 2133 (binding (where-is-internal fun overriding-local-map t)) 2134 (obsolete (get fun 'byte-obsolete-info)) 2135 (alias (symbol-function fun)) 2136 (suffix (cond ((symbolp alias) 2137 (format " (%s)" alias)) 2138 (obsolete 2139 (format " (%s)" (car obsolete))) 2140 ((and binding (not (stringp binding))) 2141 (format " (%s)" (key-description binding))) 2142 (t "")))) 2143 (put-text-property 0 (length suffix) 2144 'face 'completions-annotations suffix) 2145 (list command-name "" suffix))) 2146 command-names))) 2147 2148(defcustom suggest-key-bindings t 2149 "Non-nil means show the equivalent keybinding when \ 2150\\[execute-extended-command] has one. 2151The value can be a length of time to show the message for. 2152If the value is non-nil and not a number, we wait 2 seconds. 2153 2154Also see `extended-command-suggest-shorter'. 2155 2156Equivalent key-bindings are also shown in the completion list of 2157\\[execute-extended-command] for all commands that have them." 2158 :group 'keyboard 2159 :type '(choice (const :tag "off" nil) 2160 (natnum :tag "time" 2) 2161 (other :tag "on"))) 2162 2163(defcustom extended-command-suggest-shorter t 2164 "If non-nil, show a shorter \\[execute-extended-command] invocation \ 2165when there is one. 2166 2167Also see `suggest-key-bindings'." 2168 :group 'keyboard 2169 :type 'boolean 2170 :version "26.1") 2171 2172(defun execute-extended-command--shorter-1 (name length) 2173 (cond 2174 ((zerop length) (list "")) 2175 ((equal name "") nil) 2176 (t 2177 (nconc (mapcar (lambda (s) (concat (substring name 0 1) s)) 2178 (execute-extended-command--shorter-1 2179 (substring name 1) (1- length))) 2180 (when (string-match "\\`\\(-\\)?[^-]*" name) 2181 (execute-extended-command--shorter-1 2182 (substring name (match-end 0)) length)))))) 2183 2184(defun execute-extended-command--shorter (name typed) 2185 (let ((candidates '()) 2186 (max (length typed)) 2187 (len 1) 2188 binding) 2189 (while (and (not binding) 2190 (progn 2191 (unless candidates 2192 (setq len (1+ len)) 2193 (setq candidates (execute-extended-command--shorter-1 2194 name len))) 2195 ;; Don't show the help message if the binding isn't 2196 ;; significantly shorter than the M-x command the user typed. 2197 (< len (- max 5)))) 2198 (input-pending-p) ;Dummy call to trigger input-processing, bug#23002. 2199 (let ((candidate (pop candidates))) 2200 (when (equal name 2201 (car-safe (completion-try-completion 2202 candidate obarray 'commandp len))) 2203 (setq binding candidate)))) 2204 binding)) 2205 2206(defvar execute-extended-command--binding-timer nil) 2207 2208(defun execute-extended-command (prefixarg &optional command-name typed) 2209 ;; Based on Fexecute_extended_command in keyboard.c of Emacs. 2210 ;; Aaron S. Hawley <aaron.s.hawley(at)gmail.com> 2009-08-24 2211 "Read a command name, then read the arguments and call the command. 2212To pass a prefix argument to the command you are 2213invoking, give a prefix argument to `execute-extended-command'." 2214 (declare (interactive-only command-execute)) 2215 ;; FIXME: Remember the actual text typed by the user before completion, 2216 ;; so that we don't later on suggest the same shortening. 2217 (interactive 2218 (let ((execute-extended-command--last-typed nil)) 2219 (list current-prefix-arg 2220 (read-extended-command) 2221 execute-extended-command--last-typed))) 2222 ;; Emacs<24 calling-convention was with a single `prefixarg' argument. 2223 (unless command-name 2224 (let ((current-prefix-arg prefixarg) ; for prompt 2225 (execute-extended-command--last-typed nil)) 2226 (setq command-name (read-extended-command)) 2227 (setq typed execute-extended-command--last-typed))) 2228 (let* ((function (and (stringp command-name) (intern-soft command-name))) 2229 (binding (and suggest-key-bindings 2230 (not executing-kbd-macro) 2231 (where-is-internal function overriding-local-map t))) 2232 (delay-before-suggest 0) 2233 (find-shorter nil)) 2234 (unless (commandp function) 2235 (error "`%s' is not a valid command name" command-name)) 2236 ;; Some features, such as novice.el, rely on this-command-keys 2237 ;; including M-x COMMAND-NAME RET. 2238 (set--this-command-keys (concat "\M-x" (symbol-name function) "\r")) 2239 (setq this-command function) 2240 ;; Normally `real-this-command' should never be changed, but here we really 2241 ;; want to pretend that M-x <cmd> RET is nothing more than a "key 2242 ;; binding" for <cmd>, so the command the user really wanted to run is 2243 ;; `function' and not `execute-extended-command'. The difference is 2244 ;; visible in cases such as M-x <cmd> RET and then C-x z (bug#11506). 2245 (setq real-this-command function) 2246 (let ((prefix-arg prefixarg)) 2247 (command-execute function 'record)) 2248 ;; Ensure that we never have two of the suggest-binding timers in 2249 ;; flight. 2250 (when execute-extended-command--binding-timer 2251 (cancel-timer execute-extended-command--binding-timer)) 2252 ;; If this command displayed something in the echo area, then 2253 ;; postpone the display of our suggestion message a bit. 2254 (when (and suggest-key-bindings 2255 (or binding 2256 (and extended-command-suggest-shorter typed))) 2257 (setq delay-before-suggest 2258 (cond 2259 ((zerop (length (current-message))) 0) 2260 ((numberp suggest-key-bindings) suggest-key-bindings) 2261 (t 2))) 2262 (when (and extended-command-suggest-shorter 2263 (not binding) 2264 (not executing-kbd-macro) 2265 (symbolp function) 2266 (> (length (symbol-name function)) 2)) 2267 ;; There's no binding for CMD. Let's try and find the shortest 2268 ;; string to use in M-x. 2269 (setq find-shorter t)) 2270 (when (or binding find-shorter) 2271 (setq execute-extended-command--binding-timer 2272 (run-at-time 2273 delay-before-suggest nil 2274 (lambda () 2275 ;; If the user has typed any other commands in the 2276 ;; meantime, then don't display anything. 2277 (when (eq function real-last-command) 2278 ;; Find shorter string. 2279 (when find-shorter 2280 (while-no-input 2281 ;; FIXME: Can be slow. Cache it maybe? 2282 (setq binding (execute-extended-command--shorter 2283 (symbol-name function) typed)))) 2284 (when binding 2285 (with-temp-message 2286 (format-message "You can run the command `%s' with %s" 2287 function 2288 (if (stringp binding) 2289 (concat "M-x " binding " RET") 2290 (key-description binding))) 2291 (sit-for (if (numberp suggest-key-bindings) 2292 suggest-key-bindings 2293 2)))))))))))) 2294 2295(defun execute-extended-command-for-buffer (prefixarg &optional 2296 command-name typed) 2297 "Query user for a command relevant for the current mode, and then execute it. 2298This is like `execute-extended-command', but it limits the 2299completions to commands that are particularly relevant to the 2300current buffer. This includes commands that have been marked as 2301being specially designed for the current major mode (and enabled 2302minor modes), as well as commands bound in the active local key 2303maps." 2304 (declare (interactive-only command-execute)) 2305 (interactive 2306 (let* ((execute-extended-command--last-typed nil) 2307 (keymaps 2308 ;; The major mode's keymap and any active minor modes. 2309 (cons 2310 (current-local-map) 2311 (mapcar 2312 #'cdr 2313 (seq-filter 2314 (lambda (elem) 2315 (symbol-value (car elem))) 2316 minor-mode-map-alist)))) 2317 (read-extended-command-predicate 2318 (lambda (symbol buffer) 2319 (or (command-completion-using-modes-p symbol buffer) 2320 (where-is-internal symbol keymaps))))) 2321 (list current-prefix-arg 2322 (read-extended-command) 2323 execute-extended-command--last-typed))) 2324 (with-suppressed-warnings ((interactive-only execute-extended-command)) 2325 (execute-extended-command prefixarg command-name typed))) 2326 2327(defun command-execute (cmd &optional record-flag keys special) 2328 ;; BEWARE: Called directly from the C code. 2329 "Execute CMD as an editor command. 2330CMD must be a symbol that satisfies the `commandp' predicate. 2331 2332Optional second arg RECORD-FLAG non-nil means unconditionally put 2333this command in the variable `command-history'. Otherwise, that 2334is done only if an arg is read using the minibuffer. 2335 2336The argument KEYS specifies the value to use instead of the 2337return value of the `this-command-keys' function when reading the 2338arguments; if it is nil, `this-command-keys' is used. 2339 2340The argument SPECIAL, if non-nil, means that this command is 2341executing a special event, so ignore the prefix argument and 2342don't clear it." 2343 (setq debug-on-next-call nil) 2344 (let ((prefixarg (unless special 2345 ;; FIXME: This should probably be done around 2346 ;; pre-command-hook rather than here! 2347 (prog1 prefix-arg 2348 (setq current-prefix-arg prefix-arg) 2349 (setq prefix-arg nil) 2350 (when current-prefix-arg 2351 (prefix-command-update)))))) 2352 (if (and (symbolp cmd) 2353 (get cmd 'disabled) 2354 disabled-command-function) 2355 ;; FIXME: Weird calling convention! 2356 (run-hooks 'disabled-command-function) 2357 (let ((final cmd)) 2358 (while 2359 (progn 2360 (setq final (indirect-function final)) 2361 (if (autoloadp final) 2362 (setq final (autoload-do-load final cmd))))) 2363 (cond 2364 ((arrayp final) 2365 ;; If requested, place the macro in the command history. For 2366 ;; other sorts of commands, call-interactively takes care of this. 2367 (when record-flag 2368 (add-to-history 2369 'command-history `(execute-kbd-macro ,final ,prefixarg) nil t)) 2370 (execute-kbd-macro final prefixarg)) 2371 (t 2372 ;; Pass `cmd' rather than `final', for the backtrace's sake. 2373 (prog1 (call-interactively cmd record-flag keys) 2374 (when (and (symbolp cmd) 2375 (get cmd 'byte-obsolete-info) 2376 (not (get cmd 'command-execute-obsolete-warned))) 2377 (put cmd 'command-execute-obsolete-warned t) 2378 (message "%s" (macroexp--obsolete-warning 2379 cmd (get cmd 'byte-obsolete-info) "command")))))))))) 2380 2381(defvar minibuffer-history nil 2382 "Default minibuffer history list. 2383This is used for all minibuffer input 2384except when an alternate history list is specified. 2385 2386Maximum length of the history list is determined by the value 2387of `history-length', which see.") 2388(defvar minibuffer-history-sexp-flag nil 2389 "Control whether history list elements are expressions or strings. 2390If the value of this variable equals current minibuffer depth, 2391they are expressions; otherwise they are strings. 2392\(That convention is designed to do the right thing for 2393recursive uses of the minibuffer.)") 2394(setq minibuffer-history-variable 'minibuffer-history) 2395(setq minibuffer-history-position nil) ;; Defvar is in C code. 2396(defvar minibuffer-history-search-history nil) 2397 2398(defvar minibuffer-text-before-history nil 2399 "Text that was in this minibuffer before any history commands. 2400This is nil if there have not yet been any history commands 2401in this use of the minibuffer.") 2402 2403(add-hook 'minibuffer-setup-hook 'minibuffer-history-initialize) 2404 2405(defun minibuffer-history-initialize () 2406 (setq minibuffer-text-before-history nil)) 2407 2408(defun minibuffer-avoid-prompt (_new _old) 2409 "A point-motion hook for the minibuffer, that moves point out of the prompt." 2410 (declare (obsolete cursor-intangible-mode "25.1")) 2411 (constrain-to-field nil (point-max))) 2412 2413(defcustom minibuffer-history-case-insensitive-variables nil 2414 "Minibuffer history variables for which matching should ignore case. 2415If a history variable is a member of this list, then the 2416\\[previous-matching-history-element] and \\[next-matching-history-element]\ 2417 commands ignore case when searching it, 2418regardless of `case-fold-search'." 2419 :type '(repeat variable) 2420 :group 'minibuffer) 2421 2422(defun previous-matching-history-element (regexp n) 2423 "Find the previous history element that matches REGEXP. 2424\(Previous history elements refer to earlier actions.) 2425With prefix argument N, search for Nth previous match. 2426If N is negative, find the next or Nth next match. 2427Normally, history elements are matched case-insensitively if 2428`case-fold-search' is non-nil, but an uppercase letter in REGEXP 2429makes the search case-sensitive. 2430See also `minibuffer-history-case-insensitive-variables'." 2431 (interactive 2432 (let* ((enable-recursive-minibuffers t) 2433 (regexp (read-from-minibuffer 2434 (format-prompt "Previous element matching regexp" 2435 (and minibuffer-history-search-history 2436 (car minibuffer-history-search-history))) 2437 nil minibuffer-local-map nil 2438 'minibuffer-history-search-history 2439 (car minibuffer-history-search-history)))) 2440 ;; Use the last regexp specified, by default, if input is empty. 2441 (list (if (string= regexp "") 2442 (if minibuffer-history-search-history 2443 (car minibuffer-history-search-history) 2444 (user-error "No previous history search regexp")) 2445 regexp) 2446 (prefix-numeric-value current-prefix-arg)))) 2447 (unless (zerop n) 2448 (if (and (zerop minibuffer-history-position) 2449 (null minibuffer-text-before-history)) 2450 (setq minibuffer-text-before-history 2451 (minibuffer-contents-no-properties))) 2452 (let ((history (minibuffer-history-value)) 2453 (case-fold-search 2454 (if (isearch-no-upper-case-p regexp t) ; assume isearch.el is dumped 2455 ;; On some systems, ignore case for file names. 2456 (if (memq minibuffer-history-variable 2457 minibuffer-history-case-insensitive-variables) 2458 t 2459 ;; Respect the user's setting for case-fold-search: 2460 case-fold-search) 2461 nil)) 2462 prevpos 2463 match-string 2464 match-offset 2465 (pos minibuffer-history-position)) 2466 (while (/= n 0) 2467 (setq prevpos pos) 2468 (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history))) 2469 (when (= pos prevpos) 2470 (user-error (if (= pos 1) 2471 "No later matching history item" 2472 "No earlier matching history item"))) 2473 (setq match-string 2474 (if (eq minibuffer-history-sexp-flag (minibuffer-depth)) 2475 (let ((print-level nil)) 2476 (prin1-to-string (nth (1- pos) history))) 2477 (nth (1- pos) history))) 2478 (setq match-offset 2479 (if (< n 0) 2480 (and (string-match regexp match-string) 2481 (match-end 0)) 2482 (and (string-match (concat ".*\\(" regexp "\\)") match-string) 2483 (match-beginning 1)))) 2484 (when match-offset 2485 (setq n (+ n (if (< n 0) 1 -1))))) 2486 (setq minibuffer-history-position pos) 2487 (goto-char (point-max)) 2488 (delete-minibuffer-contents) 2489 (insert match-string) 2490 (goto-char (+ (minibuffer-prompt-end) match-offset)))) 2491 (if (memq (car (car command-history)) '(previous-matching-history-element 2492 next-matching-history-element)) 2493 (setq command-history (cdr command-history)))) 2494 2495(defun next-matching-history-element (regexp n) 2496 "Find the next history element that matches REGEXP. 2497\(The next history element refers to a more recent action.) 2498With prefix argument N, search for Nth next match. 2499If N is negative, find the previous or Nth previous match. 2500Normally, history elements are matched case-insensitively if 2501`case-fold-search' is non-nil, but an uppercase letter in REGEXP 2502makes the search case-sensitive." 2503 (interactive 2504 (let* ((enable-recursive-minibuffers t) 2505 (regexp (read-from-minibuffer "Next element matching (regexp): " 2506 nil 2507 minibuffer-local-map 2508 nil 2509 'minibuffer-history-search-history 2510 (car minibuffer-history-search-history)))) 2511 ;; Use the last regexp specified, by default, if input is empty. 2512 (list (if (string= regexp "") 2513 (if minibuffer-history-search-history 2514 (car minibuffer-history-search-history) 2515 (user-error "No previous history search regexp")) 2516 regexp) 2517 (prefix-numeric-value current-prefix-arg)))) 2518 (previous-matching-history-element regexp (- n))) 2519 2520(defvar minibuffer-temporary-goal-position nil) 2521 2522(defvar minibuffer-default-add-function 'minibuffer-default-add-completions 2523 "Function run by `goto-history-element' before consuming default values. 2524This is useful to dynamically add more elements to the list of default values 2525when `goto-history-element' reaches the end of this list. 2526Before calling this function `goto-history-element' sets the variable 2527`minibuffer-default-add-done' to t, so it will call this function only 2528once. In special cases, when this function needs to be called more 2529than once, it can set `minibuffer-default-add-done' to nil explicitly, 2530overriding the setting of this variable to t in `goto-history-element'.") 2531 2532(defvar-local minibuffer-default-add-done nil 2533 "When nil, add more elements to the end of the list of default values. 2534The value nil causes `goto-history-element' to add more elements to 2535the list of defaults when it reaches the end of this list. It does 2536this by calling a function defined by `minibuffer-default-add-function'.") 2537 2538(defun minibuffer-default-add-completions () 2539 "Return a list of all completions without the default value. 2540This function is used to add all elements of the completion table to 2541the end of the list of defaults just after the default value." 2542 (let ((def minibuffer-default) 2543 (all (all-completions "" 2544 minibuffer-completion-table 2545 minibuffer-completion-predicate))) 2546 (if (listp def) 2547 (append def all) 2548 (cons def (delete def all))))) 2549 2550(defun minibuffer-history-value () 2551 "Return the value of the minibuffer input history list. 2552If `minibuffer-history-variable' points to a buffer-local variable and 2553the minibuffer is active, return the buffer-local value for the buffer 2554that was current when the minibuffer was activated." 2555 (buffer-local-value minibuffer-history-variable 2556 (window-buffer (minibuffer-selected-window)))) 2557 2558(defun goto-history-element (nabs) 2559 "Puts element of the minibuffer history in the minibuffer. 2560The argument NABS specifies the absolute history position in 2561descending order, where 0 means the current element and a 2562positive number N means the Nth previous element. NABS being a 2563negative number -N means the Nth entry of \"future history.\"" 2564 (interactive "p") 2565 (when (and (not minibuffer-default-add-done) 2566 (functionp minibuffer-default-add-function) 2567 (< nabs (- (if (listp minibuffer-default) 2568 (length minibuffer-default) 2569 1)))) 2570 (setq minibuffer-default-add-done t 2571 minibuffer-default (funcall minibuffer-default-add-function))) 2572 (let ((minimum (if minibuffer-default 2573 (- (if (listp minibuffer-default) 2574 (length minibuffer-default) 2575 1)) 2576 0)) 2577 elt minibuffer-returned-to-present) 2578 (if (and (zerop minibuffer-history-position) 2579 (null minibuffer-text-before-history)) 2580 (setq minibuffer-text-before-history 2581 (minibuffer-contents-no-properties))) 2582 (if (< nabs minimum) 2583 (user-error (if minibuffer-default 2584 "End of defaults; no next item" 2585 "End of history; no default available"))) 2586 (if (> nabs (if (listp (minibuffer-history-value)) 2587 (length (minibuffer-history-value)) 2588 0)) 2589 (user-error "Beginning of history; no preceding item")) 2590 (unless (memq last-command '(next-history-element 2591 previous-history-element)) 2592 (let ((prompt-end (minibuffer-prompt-end))) 2593 (setq-local minibuffer-temporary-goal-position 2594 (cond ((<= (point) prompt-end) prompt-end) 2595 ((eobp) nil) 2596 (t (point)))))) 2597 (goto-char (point-max)) 2598 (delete-minibuffer-contents) 2599 (setq minibuffer-history-position nabs) 2600 (cond ((< nabs 0) 2601 (setq elt (if (listp minibuffer-default) 2602 (nth (1- (abs nabs)) minibuffer-default) 2603 minibuffer-default))) 2604 ((= nabs 0) 2605 (setq elt (or minibuffer-text-before-history "")) 2606 (setq minibuffer-returned-to-present t) 2607 (setq minibuffer-text-before-history nil)) 2608 (t (setq elt (nth (1- minibuffer-history-position) 2609 (minibuffer-history-value))))) 2610 (insert 2611 (if (and (eq minibuffer-history-sexp-flag (minibuffer-depth)) 2612 (not minibuffer-returned-to-present)) 2613 (let ((print-level nil)) 2614 (prin1-to-string elt)) 2615 elt)) 2616 (goto-char (or minibuffer-temporary-goal-position (point-max))))) 2617 2618(defun next-history-element (n) 2619 "Puts next element of the minibuffer history in the minibuffer. 2620With argument N, it uses the Nth following element. The position 2621in the history can go beyond the current position and invoke \"future 2622history.\"" 2623 (interactive "p") 2624 (or (zerop n) 2625 (goto-history-element (- minibuffer-history-position n)))) 2626 2627(defun previous-history-element (n) 2628 "Puts previous element of the minibuffer history in the minibuffer. 2629With argument N, it uses the Nth previous element." 2630 (interactive "p") 2631 (or (zerop n) 2632 (goto-history-element (+ minibuffer-history-position n)))) 2633 2634(defun next-line-or-history-element (&optional arg) 2635 "Move cursor vertically down ARG lines, or to the next history element. 2636When point moves over the bottom line of multi-line minibuffer, puts ARGth 2637next element of the minibuffer history in the minibuffer." 2638 (interactive "^p") 2639 (or arg (setq arg 1)) 2640 (let* ((old-point (point)) 2641 ;; Don't add newlines if they have the mode enabled globally. 2642 (next-line-add-newlines nil) 2643 ;; Remember the original goal column of possibly multi-line input 2644 ;; excluding the length of the prompt on the first line. 2645 (prompt-end (minibuffer-prompt-end)) 2646 (old-column (unless (and (eolp) (> (point) prompt-end)) 2647 (if (= (line-number-at-pos) 1) 2648 (max (- (current-column) 2649 (save-excursion 2650 (goto-char (1- prompt-end)) 2651 (current-column))) 2652 0) 2653 (current-column))))) 2654 (condition-case nil 2655 (with-no-warnings 2656 (next-line arg)) 2657 (end-of-buffer 2658 ;; Restore old position since `line-move-visual' moves point to 2659 ;; the end of the line when it fails to go to the next line. 2660 (goto-char old-point) 2661 (next-history-element arg) 2662 ;; Reset `temporary-goal-column' because a correct value is not 2663 ;; calculated when `next-line' above fails by bumping against 2664 ;; the bottom of the minibuffer (bug#22544). 2665 (setq temporary-goal-column 0) 2666 ;; Restore the original goal column on the last line 2667 ;; of possibly multi-line input. 2668 (goto-char (point-max)) 2669 (when old-column 2670 (if (= (line-number-at-pos) 1) 2671 (move-to-column (+ old-column 2672 (save-excursion 2673 (goto-char (1- (minibuffer-prompt-end))) 2674 (current-column)))) 2675 (move-to-column old-column))))))) 2676 2677(defun previous-line-or-history-element (&optional arg) 2678 "Move cursor vertically up ARG lines, or to the previous history element. 2679When point moves over the top line of multi-line minibuffer, puts ARGth 2680previous element of the minibuffer history in the minibuffer." 2681 (interactive "^p") 2682 (or arg (setq arg 1)) 2683 (let* ((old-point (point)) 2684 ;; Remember the original goal column of possibly multi-line input 2685 ;; excluding the length of the prompt on the first line. 2686 (prompt-end (minibuffer-prompt-end)) 2687 (old-column (unless (and (eolp) (> (point) prompt-end)) 2688 (if (= (line-number-at-pos) 1) 2689 (max (- (current-column) 2690 (save-excursion 2691 (goto-char (1- prompt-end)) 2692 (current-column))) 2693 1) 2694 (current-column))))) 2695 (condition-case nil 2696 (with-no-warnings 2697 (previous-line arg) 2698 ;; Avoid moving point to the prompt 2699 (when (< (point) (minibuffer-prompt-end)) 2700 ;; If there is minibuffer contents on the same line 2701 (if (<= (minibuffer-prompt-end) 2702 (save-excursion 2703 (if (or truncate-lines (not line-move-visual)) 2704 (end-of-line) 2705 (end-of-visual-line)) 2706 (point))) 2707 ;; Move to the beginning of minibuffer contents 2708 (goto-char (minibuffer-prompt-end)) 2709 ;; Otherwise, go to the previous history element 2710 (signal 'beginning-of-buffer nil)))) 2711 (beginning-of-buffer 2712 ;; Restore old position since `line-move-visual' moves point to 2713 ;; the beginning of the line when it fails to go to the previous line. 2714 (goto-char old-point) 2715 (previous-history-element arg) 2716 ;; Reset `temporary-goal-column' because a correct value is not 2717 ;; calculated when `previous-line' above fails by bumping against 2718 ;; the top of the minibuffer (bug#22544). 2719 (setq temporary-goal-column 0) 2720 ;; Restore the original goal column on the first line 2721 ;; of possibly multi-line input. 2722 (goto-char (minibuffer-prompt-end)) 2723 (if old-column 2724 (if (= (line-number-at-pos) 1) 2725 (move-to-column (+ old-column 2726 (save-excursion 2727 (goto-char (1- (minibuffer-prompt-end))) 2728 (current-column)))) 2729 (move-to-column old-column)) 2730 (if (not line-move-visual) ; Handle logical lines (bug#42862) 2731 (end-of-line) 2732 ;; Put the cursor at the end of the visual line instead of the 2733 ;; logical line, so the next `previous-line-or-history-element' 2734 ;; would move to the previous history element, not to a possible upper 2735 ;; visual line from the end of logical line in `line-move-visual' mode. 2736 (end-of-visual-line) 2737 ;; Since `end-of-visual-line' puts the cursor at the beginning 2738 ;; of the next visual line, move it one char back to the end 2739 ;; of the first visual line (bug#22544). 2740 (unless (eolp) (backward-char 1)))))))) 2741 2742(defun next-complete-history-element (n) 2743 "Get next history element that completes the minibuffer before the point. 2744The contents of the minibuffer after the point are deleted and replaced 2745by the new completion." 2746 (interactive "p") 2747 (let ((point-at-start (point))) 2748 (next-matching-history-element 2749 (concat 2750 "^" (regexp-quote (buffer-substring (minibuffer-prompt-end) (point)))) 2751 n) 2752 ;; next-matching-history-element always puts us at (point-min). 2753 ;; Move to the position we were at before changing the buffer contents. 2754 ;; This is still sensible, because the text before point has not changed. 2755 (goto-char point-at-start))) 2756 2757(defun previous-complete-history-element (n) 2758 "\ 2759Get previous history element that completes the minibuffer before the point. 2760The contents of the minibuffer after the point are deleted and replaced 2761by the new completion." 2762 (interactive "p") 2763 (next-complete-history-element (- n))) 2764 2765;; For compatibility with the old subr of the same name. 2766(defun minibuffer-prompt-width () 2767 "Return the display width of the minibuffer prompt. 2768Return 0 if current buffer is not a minibuffer." 2769 ;; Return the width of everything before the field at the end of 2770 ;; the buffer; this should be 0 for normal buffers. 2771 (1- (minibuffer-prompt-end))) 2772 2773;; isearch minibuffer history 2774(add-hook 'minibuffer-setup-hook 'minibuffer-history-isearch-setup) 2775 2776(defvar minibuffer-history-isearch-message-overlay) 2777(make-variable-buffer-local 'minibuffer-history-isearch-message-overlay) 2778 2779(defun minibuffer-history-isearch-setup () 2780 "Set up a minibuffer for using isearch to search the minibuffer history. 2781Intended to be added to `minibuffer-setup-hook'." 2782 (setq-local isearch-search-fun-function 2783 #'minibuffer-history-isearch-search) 2784 (setq-local isearch-message-function 2785 #'minibuffer-history-isearch-message) 2786 (setq-local isearch-wrap-function 2787 #'minibuffer-history-isearch-wrap) 2788 (setq-local isearch-push-state-function 2789 #'minibuffer-history-isearch-push-state) 2790 (add-hook 'isearch-mode-end-hook 'minibuffer-history-isearch-end nil t)) 2791 2792(defun minibuffer-history-isearch-end () 2793 "Clean up the minibuffer after terminating isearch in the minibuffer." 2794 (if minibuffer-history-isearch-message-overlay 2795 (delete-overlay minibuffer-history-isearch-message-overlay))) 2796 2797(defun minibuffer-history-isearch-search () 2798 "Return the proper search function, for isearch in minibuffer history." 2799 (lambda (string bound noerror) 2800 (let ((search-fun 2801 ;; Use standard functions to search within minibuffer text 2802 (isearch-search-fun-default)) 2803 found) 2804 ;; Avoid lazy-highlighting matches in the minibuffer prompt when 2805 ;; searching forward. Lazy-highlight calls this lambda with the 2806 ;; bound arg, so skip the minibuffer prompt. 2807 (if (and bound isearch-forward (< (point) (minibuffer-prompt-end))) 2808 (goto-char (minibuffer-prompt-end))) 2809 (or 2810 ;; 1. First try searching in the initial minibuffer text 2811 (funcall search-fun string 2812 (if isearch-forward bound (minibuffer-prompt-end)) 2813 noerror) 2814 ;; 2. If the above search fails, start putting next/prev history 2815 ;; elements in the minibuffer successively, and search the string 2816 ;; in them. Do this only when bound is nil (i.e. not while 2817 ;; lazy-highlighting search strings in the current minibuffer text). 2818 (unless bound 2819 (condition-case nil 2820 (progn 2821 (while (not found) 2822 (cond (isearch-forward 2823 (next-history-element 1) 2824 (goto-char (minibuffer-prompt-end))) 2825 (t 2826 (previous-history-element 1) 2827 (goto-char (point-max)))) 2828 (setq isearch-barrier (point) isearch-opoint (point)) 2829 ;; After putting the next/prev history element, search 2830 ;; the string in them again, until next-history-element 2831 ;; or previous-history-element raises an error at the 2832 ;; beginning/end of history. 2833 (setq found (funcall search-fun string 2834 (unless isearch-forward 2835 ;; For backward search, don't search 2836 ;; in the minibuffer prompt 2837 (minibuffer-prompt-end)) 2838 noerror))) 2839 ;; Return point of the new search result 2840 (point)) 2841 ;; Return nil when next(prev)-history-element fails 2842 (error nil))))))) 2843 2844(defun minibuffer-history-isearch-message (&optional c-q-hack ellipsis) 2845 "Display the minibuffer history search prompt. 2846If there are no search errors, this function displays an overlay with 2847the isearch prompt which replaces the original minibuffer prompt. 2848Otherwise, it displays the standard isearch message returned from 2849the function `isearch-message'." 2850 (if (not (and (minibufferp) isearch-success (not isearch-error))) 2851 ;; Use standard function `isearch-message' when not in the minibuffer, 2852 ;; or search fails, or has an error (like incomplete regexp). 2853 ;; This function overwrites minibuffer text with isearch message, 2854 ;; so it's possible to see what is wrong in the search string. 2855 (isearch-message c-q-hack ellipsis) 2856 ;; Otherwise, put the overlay with the standard isearch prompt over 2857 ;; the initial minibuffer prompt. 2858 (if (overlayp minibuffer-history-isearch-message-overlay) 2859 (move-overlay minibuffer-history-isearch-message-overlay 2860 (point-min) (minibuffer-prompt-end)) 2861 (setq minibuffer-history-isearch-message-overlay 2862 (make-overlay (point-min) (minibuffer-prompt-end))) 2863 (overlay-put minibuffer-history-isearch-message-overlay 'evaporate t)) 2864 (overlay-put minibuffer-history-isearch-message-overlay 2865 'display (isearch-message-prefix c-q-hack ellipsis)) 2866 ;; And clear any previous isearch message. 2867 (message ""))) 2868 2869(defun minibuffer-history-isearch-wrap () 2870 "Wrap the minibuffer history search when search fails. 2871Move point to the first history element for a forward search, 2872or to the last history element for a backward search." 2873 ;; When `minibuffer-history-isearch-search' fails on reaching the 2874 ;; beginning/end of the history, wrap the search to the first/last 2875 ;; minibuffer history element. 2876 (if isearch-forward 2877 (goto-history-element (length (minibuffer-history-value))) 2878 (goto-history-element 0)) 2879 (goto-char (if isearch-forward (minibuffer-prompt-end) (point-max)))) 2880 2881(defun minibuffer-history-isearch-push-state () 2882 "Save a function restoring the state of minibuffer history search. 2883Save `minibuffer-history-position' to the additional state parameter 2884in the search status stack." 2885 (let ((pos minibuffer-history-position)) 2886 (lambda (cmd) 2887 (minibuffer-history-isearch-pop-state cmd pos)))) 2888 2889(defun minibuffer-history-isearch-pop-state (_cmd hist-pos) 2890 "Restore the minibuffer history search state. 2891Go to the history element by the absolute history position HIST-POS." 2892 (goto-history-element hist-pos)) 2893 2894 2895(add-hook 'minibuffer-setup-hook 'minibuffer-error-initialize) 2896 2897(defun minibuffer-error-initialize () 2898 "Set up minibuffer error processing." 2899 (setq-local command-error-function 'minibuffer-error-function)) 2900 2901(defun minibuffer-error-function (data context caller) 2902 "Display error messages in the active minibuffer. 2903The same as `command-error-default-function' but display error messages 2904at the end of the minibuffer using `minibuffer-message' to not obscure 2905the minibuffer contents." 2906 (if (memq 'minibuffer-quit (get (car data) 'error-conditions)) 2907 (ding t) 2908 (discard-input) 2909 (ding)) 2910 (let ((string (error-message-string data))) 2911 ;; If we know from where the error was signaled, show it in 2912 ;; *Messages*. 2913 (let ((inhibit-message t)) 2914 (message "%s%s" (if caller (format "%s: " caller) "") string)) 2915 ;; Display an error message at the end of the minibuffer. 2916 (minibuffer-message (apply #'propertize (format " [%s%s]" context string) 2917 minibuffer-prompt-properties)))) 2918 2919 2920;Put this on C-x u, so we can force that rather than C-_ into startup msg 2921(define-obsolete-function-alias 'advertised-undo 'undo "23.2") 2922 2923(defconst undo-equiv-table (make-hash-table :test 'eq :weakness t) 2924 "Table mapping redo records to the corresponding undo one. 2925A redo record for an undo in region maps to 'undo-in-region. 2926A redo record for ordinary undo maps to the following (earlier) undo. 2927A redo record that undoes to the beginning of the undo list maps to t. 2928In the rare case where there are (erroneously) consecutive nil's in 2929`buffer-undo-list', `undo' maps the previous valid undo record to 2930'empty, if the previous record is a redo record, `undo' doesn't change 2931its mapping. 2932 2933To be clear, a redo record is just an undo record, the only difference 2934is that it is created by an undo command (instead of an ordinary buffer 2935edit). Since a record used to undo ordinary change is called undo 2936record, a record used to undo an undo is called redo record. 2937 2938`undo' uses this table to make sure the previous command is `undo'. 2939`undo-redo' uses this table to set the correct `pending-undo-list'. 2940 2941When you undo, `pending-undo-list' shrinks and `buffer-undo-list' 2942grows, and Emacs maps the tip of `buffer-undo-list' to the tip of 2943`pending-undo-list' in this table. 2944 2945For example, consider this undo list where each node represents an 2946undo record: if we undo from 4, `pending-undo-list' will be at 3, 2947`buffer-undo-list' at 5, and 5 will map to 3. 2948 2949 | 2950 3 5 2951 | / 2952 |/ 2953 4") 2954 2955(defvar undo-in-region nil 2956 "Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.") 2957 2958(defcustom undo-no-redo nil 2959 "If t, `undo' doesn't go through redo entries." 2960 :type 'boolean) 2961 2962(defvar pending-undo-list nil 2963 "Within a run of consecutive undo commands, list remaining to be undone. 2964If t, we undid all the way to the end of it.") 2965 2966(defun undo--last-change-was-undo-p (undo-list) 2967 (while (and (consp undo-list) (eq (car undo-list) nil)) 2968 (setq undo-list (cdr undo-list))) 2969 (gethash undo-list undo-equiv-table)) 2970 2971(defun undo (&optional arg) 2972 "Undo some previous changes. 2973Repeat this command to undo more changes. 2974A numeric ARG serves as a repeat count. 2975 2976In Transient Mark mode when the mark is active, undo changes only within 2977the current region. Similarly, when not in Transient Mark mode, just \\[universal-argument] 2978as an argument limits undo to changes within the current region." 2979 (interactive "*P") 2980 ;; Make last-command indicate for the next command that this was an undo. 2981 ;; That way, another undo will undo more. 2982 ;; If we get to the end of the undo history and get an error, 2983 ;; another undo command will find the undo history empty 2984 ;; and will get another error. To begin undoing the undos, 2985 ;; you must type some other command. 2986 (let* ((modified (buffer-modified-p)) 2987 ;; For an indirect buffer, look in the base buffer for the 2988 ;; auto-save data. 2989 (base-buffer (or (buffer-base-buffer) (current-buffer))) 2990 (recent-save (with-current-buffer base-buffer 2991 (recent-auto-save-p))) 2992 ;; Allow certain commands to inhibit an immediately following 2993 ;; undo-in-region. 2994 (inhibit-region (and (symbolp last-command) 2995 (get last-command 'undo-inhibit-region))) 2996 message) 2997 ;; If we get an error in undo-start, 2998 ;; the next command should not be a "consecutive undo". 2999 ;; So set `this-command' to something other than `undo'. 3000 (setq this-command 'undo-start) 3001 ;; Here we decide whether to break the undo chain. If the 3002 ;; previous command is `undo', we don't call `undo-start', i.e., 3003 ;; don't break the undo chain. 3004 (unless (and (eq last-command 'undo) 3005 (or (eq pending-undo-list t) 3006 ;; If something (a timer or filter?) changed the buffer 3007 ;; since the previous command, don't continue the undo seq. 3008 (undo--last-change-was-undo-p buffer-undo-list))) 3009 (setq undo-in-region 3010 (and (or (region-active-p) (and arg (not (numberp arg)))) 3011 (not inhibit-region))) 3012 (if undo-in-region 3013 (undo-start (region-beginning) (region-end)) 3014 (undo-start)) 3015 ;; get rid of initial undo boundary 3016 (undo-more 1)) 3017 ;; If we got this far, the next command should be a consecutive undo. 3018 (setq this-command 'undo) 3019 ;; Check to see whether we're hitting a redo record, and if 3020 ;; so, ask the user whether she wants to skip the redo/undo pair. 3021 (let ((equiv (gethash pending-undo-list undo-equiv-table))) 3022 (or (eq (selected-window) (minibuffer-window)) 3023 (setq message (format "%s%s" 3024 (if (or undo-no-redo (not equiv)) 3025 "Undo" "Redo") 3026 (if undo-in-region " in region" "")))) 3027 (when (and (consp equiv) undo-no-redo) 3028 ;; The equiv entry might point to another redo record if we have done 3029 ;; undo-redo-undo-redo-... so skip to the very last equiv. 3030 (while (let ((next (gethash equiv undo-equiv-table))) 3031 (if next (setq equiv next)))) 3032 (setq pending-undo-list (if (consp equiv) equiv t)))) 3033 (undo-more 3034 (if (numberp arg) 3035 (prefix-numeric-value arg) 3036 1)) 3037 ;; Record the fact that the just-generated undo records come from an 3038 ;; undo operation--that is, they are redo records. 3039 ;; In the ordinary case (not within a region), map the redo 3040 ;; record to the following undos. 3041 ;; I don't know how to do that in the undo-in-region case. 3042 (let ((list buffer-undo-list)) 3043 ;; Strip any leading undo boundaries there might be, like we do 3044 ;; above when checking. 3045 (while (eq (car list) nil) 3046 (setq list (cdr list))) 3047 (puthash list 3048 (cond 3049 (undo-in-region 'undo-in-region) 3050 ;; Prevent identity mapping. This can happen if 3051 ;; consecutive nils are erroneously in undo list. It 3052 ;; has to map to _something_ so that the next `undo' 3053 ;; command recognizes that the previous command is 3054 ;; `undo' and doesn't break the undo chain. 3055 ((eq list pending-undo-list) 3056 (or (gethash list undo-equiv-table) 3057 'empty)) 3058 (t pending-undo-list)) 3059 undo-equiv-table)) 3060 ;; Don't specify a position in the undo record for the undo command. 3061 ;; Instead, undoing this should move point to where the change is. 3062 (let ((tail buffer-undo-list) 3063 (prev nil)) 3064 (while (car tail) 3065 (when (integerp (car tail)) 3066 (let ((pos (car tail))) 3067 (if prev 3068 (setcdr prev (cdr tail)) 3069 (setq buffer-undo-list (cdr tail))) 3070 (setq tail (cdr tail)) 3071 (while (car tail) 3072 (if (eq pos (car tail)) 3073 (if prev 3074 (setcdr prev (cdr tail)) 3075 (setq buffer-undo-list (cdr tail))) 3076 (setq prev tail)) 3077 (setq tail (cdr tail))) 3078 (setq tail nil))) 3079 (setq prev tail tail (cdr tail)))) 3080 ;; Record what the current undo list says, 3081 ;; so the next command can tell if the buffer was modified in between. 3082 (and modified (not (buffer-modified-p)) 3083 (with-current-buffer base-buffer 3084 (delete-auto-save-file-if-necessary recent-save))) 3085 ;; Display a message announcing success. 3086 (if message 3087 (message "%s" message)))) 3088 3089(defun buffer-disable-undo (&optional buffer) 3090 "Make BUFFER stop keeping undo information. 3091No argument or nil as argument means do this for the current buffer." 3092 (interactive) 3093 (with-current-buffer (if buffer (get-buffer buffer) (current-buffer)) 3094 (setq buffer-undo-list t))) 3095 3096(defun undo-only (&optional arg) 3097 "Undo some previous changes. 3098Repeat this command to undo more changes. 3099A numeric ARG serves as a repeat count. 3100Contrary to `undo', this will not redo a previous undo." 3101 (interactive "*p") 3102 (let ((undo-no-redo t)) (undo arg))) 3103 3104(defun undo-redo (&optional arg) 3105 "Undo the last ARG undos, i.e., redo the last ARG changes. 3106Interactively, ARG is the prefix numeric argument and defaults to 1." 3107 (interactive "*p") 3108 (cond 3109 ((not (undo--last-change-was-undo-p buffer-undo-list)) 3110 (user-error "No undone changes to redo")) 3111 (t 3112 (let* ((ul buffer-undo-list) 3113 (new-ul 3114 (let ((undo-in-progress t)) 3115 (while (and (consp ul) (eq (car ul) nil)) 3116 (setq ul (cdr ul))) 3117 (primitive-undo (or arg 1) ul))) 3118 (new-pul (undo--last-change-was-undo-p new-ul))) 3119 (message "Redo%s" (if undo-in-region " in region" "")) 3120 (setq this-command 'undo) 3121 (setq pending-undo-list new-pul) 3122 (setq buffer-undo-list new-ul))))) 3123 3124(defvar undo-in-progress nil 3125 "Non-nil while performing an undo. 3126Some change-hooks test this variable to do something different.") 3127 3128(defun undo-more (n) 3129 "Undo back N undo-boundaries beyond what was already undone recently. 3130Call `undo-start' to get ready to undo recent changes, 3131then call `undo-more' one or more times to undo them." 3132 (or (listp pending-undo-list) 3133 (user-error (concat "No further undo information" 3134 (and undo-in-region " for region")))) 3135 (let ((undo-in-progress t)) 3136 ;; Note: The following, while pulling elements off 3137 ;; `pending-undo-list' will call primitive change functions which 3138 ;; will push more elements onto `buffer-undo-list'. 3139 (setq pending-undo-list (primitive-undo n pending-undo-list)) 3140 (if (null pending-undo-list) 3141 (setq pending-undo-list t)))) 3142 3143(defun primitive-undo (n list) 3144 "Undo N records from the front of the list LIST. 3145Return what remains of the list." 3146 3147 ;; This is a good feature, but would make undo-start 3148 ;; unable to do what is expected. 3149 ;;(when (null (car (list))) 3150 ;; ;; If the head of the list is a boundary, it is the boundary 3151 ;; ;; preceding this command. Get rid of it and don't count it. 3152 ;; (setq list (cdr list)))) 3153 3154 (let ((arg n) 3155 ;; In a writable buffer, enable undoing read-only text that is 3156 ;; so because of text properties. 3157 (inhibit-read-only t) 3158 ;; Don't let `intangible' properties interfere with undo. 3159 (inhibit-point-motion-hooks t) 3160 ;; We use oldlist only to check for EQ. ++kfs 3161 (oldlist buffer-undo-list) 3162 (did-apply nil) 3163 (next nil)) 3164 (while (> arg 0) 3165 (while (setq next (pop list)) ;Exit inner loop at undo boundary. 3166 ;; Handle an integer by setting point to that value. 3167 (pcase next 3168 ((pred integerp) (goto-char next)) 3169 ;; Element (t . TIME) records previous modtime. 3170 ;; Preserve any flag of NONEXISTENT_MODTIME_NSECS or 3171 ;; UNKNOWN_MODTIME_NSECS. 3172 (`(t . ,time) 3173 ;; If this records an obsolete save 3174 ;; (not matching the actual disk file) 3175 ;; then don't mark unmodified. 3176 (when (or (equal time (visited-file-modtime)) 3177 (and (consp time) 3178 (equal (list (car time) (cdr time)) 3179 (visited-file-modtime)))) 3180 (unlock-buffer) 3181 (set-buffer-modified-p nil))) 3182 ;; Element (nil PROP VAL BEG . END) is property change. 3183 (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare)) 3184 (when (or (> (point-min) beg) (< (point-max) end)) 3185 (error "Changes to be undone are outside visible portion of buffer")) 3186 (put-text-property beg end prop val)) 3187 ;; Element (BEG . END) means range was inserted. 3188 (`(,(and beg (pred integerp)) . ,(and end (pred integerp))) 3189 ;; (and `(,beg . ,end) `(,(pred integerp) . ,(pred integerp))) 3190 ;; Ideally: `(,(pred integerp beg) . ,(pred integerp end)) 3191 (when (or (> (point-min) beg) (< (point-max) end)) 3192 (error "Changes to be undone are outside visible portion of buffer")) 3193 ;; Set point first thing, so that undoing this undo 3194 ;; does not send point back to where it is now. 3195 (goto-char beg) 3196 (delete-region beg end)) 3197 ;; Element (apply FUN . ARGS) means call FUN to undo. 3198 (`(apply . ,fun-args) 3199 (let ((currbuff (current-buffer))) 3200 (if (integerp (car fun-args)) 3201 ;; Long format: (apply DELTA START END FUN . ARGS). 3202 (pcase-let* ((`(,delta ,start ,end ,fun . ,args) fun-args) 3203 (start-mark (copy-marker start nil)) 3204 (end-mark (copy-marker end t))) 3205 (when (or (> (point-min) start) (< (point-max) end)) 3206 (error "Changes to be undone are outside visible portion of buffer")) 3207 (apply fun args) ;; Use `save-current-buffer'? 3208 ;; Check that the function did what the entry 3209 ;; said it would do. 3210 (unless (and (= start start-mark) 3211 (= (+ delta end) end-mark)) 3212 (error "Changes to be undone by function different from announced")) 3213 (set-marker start-mark nil) 3214 (set-marker end-mark nil)) 3215 (apply fun-args)) 3216 (unless (eq currbuff (current-buffer)) 3217 (error "Undo function switched buffer")) 3218 (setq did-apply t))) 3219 ;; Element (STRING . POS) means STRING was deleted. 3220 (`(,(and string (pred stringp)) . ,(and pos (pred integerp))) 3221 (let ((valid-marker-adjustments nil) 3222 (apos (abs pos))) 3223 (when (or (< apos (point-min)) (> apos (point-max))) 3224 (error "Changes to be undone are outside visible portion of buffer")) 3225 ;; Check that marker adjustments which were recorded 3226 ;; with the (STRING . POS) record are still valid, ie 3227 ;; the markers haven't moved. We check their validity 3228 ;; before reinserting the string so as we don't need to 3229 ;; mind marker insertion-type. 3230 (while (and (markerp (car-safe (car list))) 3231 (integerp (cdr-safe (car list)))) 3232 (let* ((marker-adj (pop list)) 3233 (m (car marker-adj))) 3234 (and (eq (marker-buffer m) (current-buffer)) 3235 (= apos m) 3236 (push marker-adj valid-marker-adjustments)))) 3237 ;; Insert string and adjust point 3238 (if (< pos 0) 3239 (progn 3240 (goto-char (- pos)) 3241 (insert string)) 3242 (goto-char pos) 3243 (insert string) 3244 (goto-char pos)) 3245 ;; Adjust the valid marker adjustments 3246 (dolist (adj valid-marker-adjustments) 3247 ;; Insert might have invalidated some of the markers 3248 ;; via modification hooks. Update only the currently 3249 ;; valid ones (bug#25599). 3250 (if (marker-buffer (car adj)) 3251 (set-marker (car adj) 3252 (- (car adj) (cdr adj))))))) 3253 ;; (MARKER . OFFSET) means a marker MARKER was adjusted by OFFSET. 3254 (`(,(and marker (pred markerp)) . ,(and offset (pred integerp))) 3255 (warn "Encountered %S entry in undo list with no matching (TEXT . POS) entry" 3256 next) 3257 ;; Even though these elements are not expected in the undo 3258 ;; list, adjust them to be conservative for the 24.4 3259 ;; release. (Bug#16818) 3260 (when (marker-buffer marker) 3261 (set-marker marker 3262 (- marker offset) 3263 (marker-buffer marker)))) 3264 (_ (error "Unrecognized entry in undo list %S" next)))) 3265 (setq arg (1- arg))) 3266 ;; Make sure an apply entry produces at least one undo entry, 3267 ;; so the test in `undo' for continuing an undo series 3268 ;; will work right. 3269 (if (and did-apply 3270 (eq oldlist buffer-undo-list)) 3271 (setq buffer-undo-list 3272 (cons (list 'apply 'cdr nil) buffer-undo-list)))) 3273 list) 3274 3275;; Deep copy of a list 3276(defun undo-copy-list (list) 3277 "Make a copy of undo list LIST." 3278 (mapcar 'undo-copy-list-1 list)) 3279 3280(defun undo-copy-list-1 (elt) 3281 (if (consp elt) 3282 (cons (car elt) (undo-copy-list-1 (cdr elt))) 3283 elt)) 3284 3285(defun undo-start (&optional beg end) 3286 "Set `pending-undo-list' to the front of the undo list. 3287The next call to `undo-more' will undo the most recently made change. 3288If BEG and END are specified, then undo only elements 3289that apply to text between BEG and END are used; other undo elements 3290are ignored. If BEG and END are nil, all undo elements are used." 3291 (if (eq buffer-undo-list t) 3292 (user-error "No undo information in this buffer")) 3293 (setq pending-undo-list 3294 (if (and beg end (not (= beg end))) 3295 (undo-make-selective-list (min beg end) (max beg end)) 3296 buffer-undo-list))) 3297 3298;; The positions given in elements of the undo list are the positions 3299;; as of the time that element was recorded to undo history. In 3300;; general, subsequent buffer edits render those positions invalid in 3301;; the current buffer, unless adjusted according to the intervening 3302;; undo elements. 3303;; 3304;; Undo in region is a use case that requires adjustments to undo 3305;; elements. It must adjust positions of elements in the region based 3306;; on newer elements not in the region so as they may be correctly 3307;; applied in the current buffer. undo-make-selective-list 3308;; accomplishes this with its undo-deltas list of adjustments. An 3309;; example undo history from oldest to newest: 3310;; 3311;; buf pos: 3312;; 123456789 buffer-undo-list undo-deltas 3313;; --------- ---------------- ----------- 3314;; aaa (1 . 4) (1 . -3) 3315;; aaba (3 . 4) N/A (in region) 3316;; ccaaba (1 . 3) (1 . -2) 3317;; ccaabaddd (7 . 10) (7 . -3) 3318;; ccaabdd ("ad" . 6) (6 . 2) 3319;; ccaabaddd (6 . 8) (6 . -2) 3320;; | |<-- region: "caab", from 2 to 6 3321;; 3322;; When the user starts a run of undos in region, 3323;; undo-make-selective-list is called to create the full list of in 3324;; region elements. Each element is adjusted forward chronologically 3325;; through undo-deltas to determine if it is in the region. 3326;; 3327;; In the above example, the insertion of "b" is (3 . 4) in the 3328;; buffer-undo-list. The undo-delta (1 . -2) causes (3 . 4) to become 3329;; (5 . 6). The next three undo-deltas cause no adjustment, so (5 3330;; . 6) is assessed as in the region and placed in the selective list. 3331;; Notably, the end of region itself adjusts from "2 to 6" to "2 to 5" 3332;; due to the selected element. The "b" insertion is the only element 3333;; fully in the region, so in this example undo-make-selective-list 3334;; returns (nil (5 . 6)). 3335;; 3336;; The adjustment of the (7 . 10) insertion of "ddd" shows an edge 3337;; case. It is adjusted through the undo-deltas: ((6 . 2) (6 . -2)). 3338;; Normally an undo-delta of (6 . 2) would cause positions after 6 to 3339;; adjust by 2. However, they shouldn't adjust to less than 6, so (7 3340;; . 10) adjusts to (6 . 8) due to the first undo delta. 3341;; 3342;; More interesting is how to adjust the "ddd" insertion due to the 3343;; next undo-delta: (6 . -2), corresponding to reinsertion of "ad". 3344;; If the reinsertion was a manual retyping of "ad", then the total 3345;; adjustment should be (7 . 10) -> (6 . 8) -> (8 . 10). However, if 3346;; the reinsertion was due to undo, one might expect the first "d" 3347;; character would again be a part of the "ddd" text, meaning its 3348;; total adjustment would be (7 . 10) -> (6 . 8) -> (7 . 10). 3349;; 3350;; undo-make-selective-list assumes in this situation that "ad" was a 3351;; new edit, even if it was inserted because of an undo. 3352;; Consequently, if the user undos in region "8 to 10" of the 3353;; "ccaabaddd" buffer, they could be surprised that it becomes 3354;; "ccaabad", as though the first "d" became detached from the 3355;; original "ddd" insertion. This quirk is a FIXME. 3356 3357(defun undo-make-selective-list (start end) 3358 "Return a list of undo elements for the region START to END. 3359The elements come from `buffer-undo-list', but we keep only the 3360elements inside this region, and discard those outside this 3361region. The elements' positions are adjusted so as the returned 3362list can be applied to the current buffer." 3363 (let ((ulist buffer-undo-list) 3364 ;; A list of position adjusted undo elements in the region. 3365 (selective-list (list nil)) 3366 ;; A list of undo-deltas for out of region undo elements. 3367 undo-deltas 3368 undo-elt) 3369 (while ulist 3370 (when undo-no-redo 3371 (while (consp (gethash ulist undo-equiv-table)) 3372 (setq ulist (gethash ulist undo-equiv-table)))) 3373 (setq undo-elt (car ulist)) 3374 (cond 3375 ((null undo-elt) 3376 ;; Don't put two nils together in the list 3377 (when (car selective-list) 3378 (push nil selective-list))) 3379 ((and (consp undo-elt) (eq (car undo-elt) t)) 3380 ;; This is a "was unmodified" element. Keep it 3381 ;; if we have kept everything thus far. 3382 (when (not undo-deltas) 3383 (push undo-elt selective-list))) 3384 ;; Skip over marker adjustments, instead relying 3385 ;; on finding them after (TEXT . POS) elements 3386 ((markerp (car-safe undo-elt)) 3387 nil) 3388 (t 3389 (let ((adjusted-undo-elt (undo-adjust-elt undo-elt 3390 undo-deltas))) 3391 (if (undo-elt-in-region adjusted-undo-elt start end) 3392 (progn 3393 (setq end (+ end (cdr (undo-delta adjusted-undo-elt)))) 3394 (push adjusted-undo-elt selective-list) 3395 ;; Keep (MARKER . ADJUSTMENT) if their (TEXT . POS) was 3396 ;; kept. primitive-undo may discard them later. 3397 (when (and (stringp (car-safe adjusted-undo-elt)) 3398 (integerp (cdr-safe adjusted-undo-elt))) 3399 (let ((list-i (cdr ulist))) 3400 (while (markerp (car-safe (car list-i))) 3401 (push (pop list-i) selective-list))))) 3402 (let ((delta (undo-delta undo-elt))) 3403 (when (/= 0 (cdr delta)) 3404 (push delta undo-deltas))))))) 3405 (pop ulist)) 3406 (nreverse selective-list))) 3407 3408(defun undo-elt-in-region (undo-elt start end) 3409 "Determine whether UNDO-ELT falls inside the region START ... END. 3410If it crosses the edge, we return nil. 3411 3412Generally this function is not useful for determining 3413whether (MARKER . ADJUSTMENT) undo elements are in the region, 3414because markers can be arbitrarily relocated. Instead, pass the 3415marker adjustment's corresponding (TEXT . POS) element." 3416 (cond ((integerp undo-elt) 3417 (and (>= undo-elt start) 3418 (<= undo-elt end))) 3419 ((eq undo-elt nil) 3420 t) 3421 ((atom undo-elt) 3422 nil) 3423 ((stringp (car undo-elt)) 3424 ;; (TEXT . POSITION) 3425 (and (>= (abs (cdr undo-elt)) start) 3426 (<= (abs (cdr undo-elt)) end))) 3427 ((and (consp undo-elt) (markerp (car undo-elt))) 3428 ;; (MARKER . ADJUSTMENT) 3429 (<= start (car undo-elt) end)) 3430 ((null (car undo-elt)) 3431 ;; (nil PROPERTY VALUE BEG . END) 3432 (let ((tail (nthcdr 3 undo-elt))) 3433 (and (>= (car tail) start) 3434 (<= (cdr tail) end)))) 3435 ((integerp (car undo-elt)) 3436 ;; (BEGIN . END) 3437 (and (>= (car undo-elt) start) 3438 (<= (cdr undo-elt) end))))) 3439 3440(defun undo-elt-crosses-region (undo-elt start end) 3441 "Test whether UNDO-ELT crosses one edge of that region START ... END. 3442This assumes we have already decided that UNDO-ELT 3443is not *inside* the region START...END." 3444 (declare (obsolete nil "25.1")) 3445 (cond ((atom undo-elt) nil) 3446 ((null (car undo-elt)) 3447 ;; (nil PROPERTY VALUE BEG . END) 3448 (let ((tail (nthcdr 3 undo-elt))) 3449 (and (< (car tail) end) 3450 (> (cdr tail) start)))) 3451 ((integerp (car undo-elt)) 3452 ;; (BEGIN . END) 3453 (and (< (car undo-elt) end) 3454 (> (cdr undo-elt) start))))) 3455 3456(defun undo-adjust-elt (elt deltas) 3457 "Return adjustment of undo element ELT by the undo DELTAS list." 3458 (pcase elt 3459 ;; POSITION 3460 ((pred integerp) 3461 (undo-adjust-pos elt deltas)) 3462 ;; (BEG . END) 3463 (`(,(and beg (pred integerp)) . ,(and end (pred integerp))) 3464 (undo-adjust-beg-end beg end deltas)) 3465 ;; (TEXT . POSITION) 3466 (`(,(and text (pred stringp)) . ,(and pos (pred integerp))) 3467 (cons text (* (if (< pos 0) -1 1) 3468 (undo-adjust-pos (abs pos) deltas)))) 3469 ;; (nil PROPERTY VALUE BEG . END) 3470 (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare)) 3471 `(nil ,prop ,val . ,(undo-adjust-beg-end beg end deltas))) 3472 ;; (apply DELTA START END FUN . ARGS) 3473 ;; FIXME 3474 ;; All others return same elt 3475 (_ elt))) 3476 3477;; (BEG . END) can adjust to the same positions, commonly when an 3478;; insertion was undone and they are out of region, for example: 3479;; 3480;; buf pos: 3481;; 123456789 buffer-undo-list undo-deltas 3482;; --------- ---------------- ----------- 3483;; [...] 3484;; abbaa (2 . 4) (2 . -2) 3485;; aaa ("bb" . 2) (2 . 2) 3486;; [...] 3487;; 3488;; "bb" insertion (2 . 4) adjusts to (2 . 2) because of the subsequent 3489;; undo. Further adjustments to such an element should be the same as 3490;; for (TEXT . POSITION) elements. The options are: 3491;; 3492;; 1: POSITION adjusts using <= (use-< nil), resulting in behavior 3493;; analogous to marker insertion-type t. 3494;; 3495;; 2: POSITION adjusts using <, resulting in behavior analogous to 3496;; marker insertion-type nil. 3497;; 3498;; There was no strong reason to prefer one or the other, except that 3499;; the first is more consistent with prior undo in region behavior. 3500(defun undo-adjust-beg-end (beg end deltas) 3501 "Return cons of adjustments to BEG and END by the undo DELTAS list." 3502 (let ((adj-beg (undo-adjust-pos beg deltas))) 3503 ;; Note: option 2 above would be like (cons (min ...) adj-end) 3504 (cons adj-beg 3505 (max adj-beg (undo-adjust-pos end deltas t))))) 3506 3507(defun undo-adjust-pos (pos deltas &optional use-<) 3508 "Return adjustment of POS by the undo DELTAS list, comparing 3509with < or <= based on USE-<." 3510 (dolist (d deltas pos) 3511 (when (if use-< 3512 (< (car d) pos) 3513 (<= (car d) pos)) 3514 (setq pos 3515 ;; Don't allow pos to become less than the undo-delta 3516 ;; position. This edge case is described in the overview 3517 ;; comments. 3518 (max (car d) (- pos (cdr d))))))) 3519 3520;; Return the first affected buffer position and the delta for an undo element 3521;; delta is defined as the change in subsequent buffer positions if we *did* 3522;; the undo. 3523(defun undo-delta (undo-elt) 3524 (if (consp undo-elt) 3525 (cond ((stringp (car undo-elt)) 3526 ;; (TEXT . POSITION) 3527 (cons (abs (cdr undo-elt)) (length (car undo-elt)))) 3528 ((integerp (car undo-elt)) 3529 ;; (BEGIN . END) 3530 (cons (car undo-elt) (- (car undo-elt) (cdr undo-elt)))) 3531 (t 3532 '(0 . 0))) 3533 '(0 . 0))) 3534 3535;;; Default undo-boundary addition 3536;; 3537;; This section adds a new undo-boundary at either after a command is 3538;; called or in some cases on a timer called after a change is made in 3539;; any buffer. 3540(defvar-local undo-auto--last-boundary-cause nil 3541 "Describe the cause of the last `undo-boundary'. 3542 3543If `explicit', the last boundary was caused by an explicit call to 3544`undo-boundary', that is one not called by the code in this 3545section. 3546 3547If it is equal to `timer', then the last boundary was inserted 3548by `undo-auto--boundary-timer'. 3549 3550If it is equal to `command', then the last boundary was inserted 3551automatically after a command, that is by the code defined in 3552this section. 3553 3554If it is equal to a list, then the last boundary was inserted by 3555an amalgamating command. The car of the list is the number of 3556times an amalgamating command has been called, and the cdr are the 3557buffers that were changed during the last command.") 3558 3559(defvar undo-auto-current-boundary-timer nil 3560 "Current timer which will run `undo-auto--boundary-timer' or nil. 3561 3562If set to non-nil, this will effectively disable the timer.") 3563 3564(defvar undo-auto--this-command-amalgamating nil 3565 "Non-nil if `this-command' should be amalgamated. 3566This variable is set to nil by `undo-auto--boundaries' and is set 3567by `undo-auto-amalgamate'." ) 3568 3569(defun undo-auto--needs-boundary-p () 3570 "Return non-nil if `buffer-undo-list' needs a boundary at the start." 3571 (car-safe buffer-undo-list)) 3572 3573(defun undo-auto--last-boundary-amalgamating-number () 3574 "Return the number of amalgamating last commands or nil. 3575Amalgamating commands are, by default, either 3576`self-insert-command' and `delete-char', but can be any command 3577that calls `undo-auto-amalgamate'." 3578 (car-safe undo-auto--last-boundary-cause)) 3579 3580(defun undo-auto--ensure-boundary (cause) 3581 "Add an `undo-boundary' to the current buffer if needed. 3582REASON describes the reason that the boundary is being added; see 3583`undo-auto--last-boundary-cause' for more information." 3584 (when (and 3585 (undo-auto--needs-boundary-p)) 3586 (let ((last-amalgamating 3587 (undo-auto--last-boundary-amalgamating-number))) 3588 (undo-boundary) 3589 (setq undo-auto--last-boundary-cause 3590 (if (eq 'amalgamate cause) 3591 (cons 3592 (if last-amalgamating (1+ last-amalgamating) 0) 3593 undo-auto--undoably-changed-buffers) 3594 cause))))) 3595 3596(defun undo-auto--boundaries (cause) 3597 "Check recently changed buffers and add a boundary if necessary. 3598REASON describes the reason that the boundary is being added; see 3599`undo-last-boundary' for more information." 3600 ;; (Bug #23785) All commands should ensure that there is an undo 3601 ;; boundary whether they have changed the current buffer or not. 3602 (when (eq cause 'command) 3603 (add-to-list 'undo-auto--undoably-changed-buffers (current-buffer))) 3604 (dolist (b undo-auto--undoably-changed-buffers) 3605 (when (buffer-live-p b) 3606 (with-current-buffer b 3607 (undo-auto--ensure-boundary cause)))) 3608 (setq undo-auto--undoably-changed-buffers nil)) 3609 3610(defun undo-auto--boundary-timer () 3611 "Timer function run by `undo-auto-current-boundary-timer'." 3612 (setq undo-auto-current-boundary-timer nil) 3613 (undo-auto--boundaries 'timer)) 3614 3615(defun undo-auto--boundary-ensure-timer () 3616 "Ensure that the `undo-auto-current-boundary-timer' is set." 3617 (unless undo-auto-current-boundary-timer 3618 (setq undo-auto-current-boundary-timer 3619 (run-at-time 10 nil #'undo-auto--boundary-timer)))) 3620 3621(defvar undo-auto--undoably-changed-buffers nil 3622 "List of buffers that have changed recently. 3623 3624This list is maintained by `undo-auto--undoable-change' and 3625`undo-auto--boundaries' and can be affected by changes to their 3626default values.") 3627 3628(defun undo-auto--add-boundary () 3629 "Add an `undo-boundary' in appropriate buffers." 3630 (undo-auto--boundaries 3631 (let ((amal undo-auto--this-command-amalgamating)) 3632 (setq undo-auto--this-command-amalgamating nil) 3633 (if amal 3634 'amalgamate 3635 'command)))) 3636 3637(defun undo-auto-amalgamate () 3638 "Amalgamate undo if necessary. 3639This function can be called before an amalgamating command. It 3640removes the previous `undo-boundary' if a series of such calls 3641have been made. By default `self-insert-command' and 3642`delete-char' are the only amalgamating commands, although this 3643function could be called by any command wishing to have this 3644behavior." 3645 (let ((last-amalgamating-count 3646 (undo-auto--last-boundary-amalgamating-number))) 3647 (setq undo-auto--this-command-amalgamating t) 3648 (when last-amalgamating-count 3649 (if (and (< last-amalgamating-count amalgamating-undo-limit) 3650 (eq this-command last-command)) 3651 ;; Amalgamate all buffers that have changed. 3652 ;; This may be needed for example if some *-change-functions 3653 ;; reflected these changes in some other buffer. 3654 (dolist (b (cdr undo-auto--last-boundary-cause)) 3655 (when (buffer-live-p b) 3656 (with-current-buffer 3657 b 3658 (when (and (consp buffer-undo-list) 3659 ;; `car-safe' doesn't work because 3660 ;; `buffer-undo-list' need not be a list! 3661 (null (car buffer-undo-list))) 3662 ;; The head of `buffer-undo-list' is nil. 3663 (setq buffer-undo-list 3664 (cdr buffer-undo-list)))))) 3665 (setq undo-auto--last-boundary-cause 0))))) 3666 3667(defun undo-auto--undoable-change () 3668 "Called after every undoable buffer change." 3669 (unless (memq (current-buffer) undo-auto--undoably-changed-buffers) 3670 (let ((bufs undo-auto--undoably-changed-buffers)) 3671 ;; Drop dead buffers from the list, to avoid memory leak in 3672 ;; (while t (with-temp-buffer (setq buffer-undo-list nil) (insert "a"))) 3673 (while bufs 3674 (let ((next (cdr bufs))) 3675 (if (or (buffer-live-p (car bufs)) (null next)) 3676 (setq bufs next) 3677 (setcar bufs (car next)) 3678 (setcdr bufs (cdr next)))))) 3679 (push (current-buffer) undo-auto--undoably-changed-buffers)) 3680 (undo-auto--boundary-ensure-timer)) 3681;; End auto-boundary section 3682 3683(defun undo-amalgamate-change-group (handle) 3684 "Amalgamate changes in change-group since HANDLE. 3685Remove all undo boundaries between the state of HANDLE and now. 3686HANDLE is as returned by `prepare-change-group'." 3687 (dolist (elt handle) 3688 (with-current-buffer (car elt) 3689 (setq elt (cdr elt)) 3690 (when (consp buffer-undo-list) 3691 (let ((old-car (car-safe elt)) 3692 (old-cdr (cdr-safe elt))) 3693 (unwind-protect 3694 (progn 3695 ;; Temporarily truncate the undo log at ELT. 3696 (when (consp elt) 3697 (setcar elt t) (setcdr elt nil)) 3698 (when 3699 (or (null elt) ;The undo-log was empty. 3700 ;; `elt' is still in the log: normal case. 3701 (eq elt (last buffer-undo-list)) 3702 ;; `elt' is not in the log any more, but that's because 3703 ;; the log is "all new", so we should remove all 3704 ;; boundaries from it. 3705 (not (eq (last buffer-undo-list) (last old-cdr)))) 3706 (cl-callf (lambda (x) (delq nil x)) 3707 (if (car buffer-undo-list) 3708 buffer-undo-list 3709 ;; Preserve the undo-boundaries at either ends of the 3710 ;; change-groups. 3711 (cdr buffer-undo-list))))) 3712 ;; Reset the modified cons cell ELT to its original content. 3713 (when (consp elt) 3714 (setcar elt old-car) 3715 (setcdr elt old-cdr)))))))) 3716 3717 3718(defcustom undo-ask-before-discard nil 3719 "If non-nil ask about discarding undo info for the current command. 3720Normally, Emacs discards the undo info for the current command if 3721it exceeds `undo-outer-limit'. But if you set this option 3722non-nil, it asks in the echo area whether to discard the info. 3723If you answer no, there is a slight risk that Emacs might crash, so 3724do it only if you really want to undo the command. 3725 3726This option is mainly intended for debugging. You have to be 3727careful if you use it for other purposes. Garbage collection is 3728inhibited while the question is asked, meaning that Emacs might 3729leak memory. So you should make sure that you do not wait 3730excessively long before answering the question." 3731 :type 'boolean 3732 :group 'undo 3733 :version "22.1") 3734 3735(defvar-local undo-extra-outer-limit nil 3736 "If non-nil, an extra level of size that's ok in an undo item. 3737We don't ask the user about truncating the undo list until the 3738current item gets bigger than this amount. 3739 3740This variable matters only if `undo-ask-before-discard' is non-nil.") 3741 3742;; When the first undo batch in an undo list is longer than 3743;; undo-outer-limit, this function gets called to warn the user that 3744;; the undo info for the current command was discarded. Garbage 3745;; collection is inhibited around the call, so it had better not do a 3746;; lot of consing. 3747(setq undo-outer-limit-function 'undo-outer-limit-truncate) 3748(defun undo-outer-limit-truncate (size) 3749 (if undo-ask-before-discard 3750 (when (or (null undo-extra-outer-limit) 3751 (> size undo-extra-outer-limit)) 3752 ;; Don't ask the question again unless it gets even bigger. 3753 ;; This applies, in particular, if the user quits from the question. 3754 ;; Such a quit quits out of GC, but something else will call GC 3755 ;; again momentarily. It will call this function again, 3756 ;; but we don't want to ask the question again. 3757 (setq undo-extra-outer-limit (+ size 50000)) 3758 (if (let (use-dialog-box track-mouse executing-kbd-macro ) 3759 (yes-or-no-p (format-message 3760 "Buffer `%s' undo info is %d bytes long; discard it? " 3761 (buffer-name) size))) 3762 (progn (setq buffer-undo-list nil) 3763 (setq undo-extra-outer-limit nil) 3764 t) 3765 nil)) 3766 (display-warning '(undo discard-info) 3767 (concat 3768 (format-message 3769 "Buffer `%s' undo info was %d bytes long.\n" 3770 (buffer-name) size) 3771 "The undo info was discarded because it exceeded \ 3772`undo-outer-limit'. 3773 3774This is normal if you executed a command that made a huge change 3775to the buffer. In that case, to prevent similar problems in the 3776future, set `undo-outer-limit' to a value that is large enough to 3777cover the maximum size of normal changes you expect a single 3778command to make, but not so large that it might exceed the 3779maximum memory allotted to Emacs. 3780 3781If you did not execute any such command, the situation is 3782probably due to a bug and you should report it. 3783 3784You can disable the popping up of this buffer by adding the entry 3785\(undo discard-info) to the user option `warning-suppress-types', 3786which is defined in the `warnings' library.\n") 3787 :warning) 3788 (setq buffer-undo-list nil) 3789 t)) 3790 3791;;;; Shell commands 3792 3793(defconst shell-command-buffer-name "*Shell Command Output*" 3794 "Name of the output buffer for shell commands.") 3795 3796(defconst shell-command-buffer-name-async "*Async Shell Command*" 3797 "Name of the output buffer for asynchronous shell commands.") 3798 3799(defvar shell-command-history nil 3800 "History list for some commands that read shell commands. 3801 3802Maximum length of the history list is determined by the value 3803of `history-length', which see.") 3804 3805(defvar shell-command-switch (purecopy "-c") 3806 "Switch used to have the shell execute its command line argument.") 3807 3808(defvar shell-command-default-error-buffer nil 3809 "Buffer name for `shell-command' and `shell-command-on-region' error output. 3810This buffer is used when `shell-command' or `shell-command-on-region' 3811is run interactively. A value of nil means that output to stderr and 3812stdout will be intermixed in the output stream.") 3813 3814(declare-function mailcap-file-default-commands "mailcap" (files)) 3815(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) 3816 3817(defun minibuffer-default-add-shell-commands () 3818 "Return a list of all commands associated with the current file. 3819This function is used to add all related commands retrieved by `mailcap' 3820to the end of the list of defaults just after the default value." 3821 (interactive) 3822 (let* ((filename (if (listp minibuffer-default) 3823 (car minibuffer-default) 3824 minibuffer-default)) 3825 (commands (and filename (require 'mailcap nil t) 3826 (mailcap-file-default-commands (list filename))))) 3827 (setq commands (mapcar (lambda (command) 3828 (concat command " " filename)) 3829 commands)) 3830 (if (listp minibuffer-default) 3831 (append minibuffer-default commands) 3832 (cons minibuffer-default commands)))) 3833 3834(declare-function shell-completion-vars "shell" ()) 3835 3836(defvar minibuffer-local-shell-command-map 3837 (let ((map (make-sparse-keymap))) 3838 (set-keymap-parent map minibuffer-local-map) 3839 (define-key map "\t" 'completion-at-point) 3840 map) 3841 "Keymap used for completing shell commands in minibuffer.") 3842 3843(defun read-shell-command (prompt &optional initial-contents hist &rest args) 3844 "Read a shell command from the minibuffer. 3845The arguments are the same as the ones of `read-from-minibuffer', 3846except READ and KEYMAP are missing and HIST defaults 3847to `shell-command-history'." 3848 (require 'shell) 3849 (minibuffer-with-setup-hook 3850 (lambda () 3851 (shell-completion-vars) 3852 (setq-local minibuffer-default-add-function 3853 #'minibuffer-default-add-shell-commands)) 3854 (apply #'read-from-minibuffer prompt initial-contents 3855 minibuffer-local-shell-command-map 3856 nil 3857 (or hist 'shell-command-history) 3858 args))) 3859 3860(defcustom async-shell-command-buffer 'confirm-new-buffer 3861 "What to do when the output buffer is used by another shell command. 3862This option specifies how to resolve the conflict where a new command 3863wants to direct its output to the buffer whose name is stored 3864in `shell-command-buffer-name-async', but that buffer is already 3865taken by another running shell command. 3866 3867The value `confirm-kill-process' is used to ask for confirmation before 3868killing the already running process and running a new process 3869in the same buffer, `confirm-new-buffer' for confirmation before running 3870the command in a new buffer with a name other than the default buffer name, 3871`new-buffer' for doing the same without confirmation, 3872`confirm-rename-buffer' for confirmation before renaming the existing 3873output buffer and running a new command in the default buffer, 3874`rename-buffer' for doing the same without confirmation." 3875 :type '(choice (const :tag "Confirm killing of running command" 3876 confirm-kill-process) 3877 (const :tag "Confirm creation of a new buffer" 3878 confirm-new-buffer) 3879 (const :tag "Create a new buffer" 3880 new-buffer) 3881 (const :tag "Confirm renaming of existing buffer" 3882 confirm-rename-buffer) 3883 (const :tag "Rename the existing buffer" 3884 rename-buffer)) 3885 :group 'shell 3886 :version "24.3") 3887 3888(defcustom async-shell-command-display-buffer t 3889 "Whether to display the command buffer immediately. 3890If t, display the buffer immediately; if nil, wait until there 3891is output." 3892 :type '(choice (const :tag "Display buffer immediately" 3893 t) 3894 (const :tag "Display buffer on output" 3895 nil)) 3896 :group 'shell 3897 :version "26.1") 3898 3899(defcustom async-shell-command-width nil 3900 "Number of display columns available for asynchronous shell command output. 3901If nil, use the shell default number (usually 80 columns). 3902If a positive integer, tell the shell to use that number of columns for 3903command output." 3904 :type '(choice (const :tag "Use system limit" nil) 3905 (integer :tag "Fixed width" :value 80)) 3906 :group 'shell 3907 :version "27.1") 3908 3909(defcustom shell-command-prompt-show-cwd nil 3910 "If non-nil, show current directory when prompting for a shell command. 3911This affects `shell-command' and `async-shell-command'." 3912 :type 'boolean 3913 :group 'shell 3914 :version "27.1") 3915 3916(defcustom shell-command-dont-erase-buffer nil 3917 "Whether to erase the output buffer before executing shell command. 3918 3919A nil value erases the output buffer before execution of the 3920shell command, except when the output buffer is the current one. 3921 3922The value `erase' ensures the output buffer is erased before 3923execution of the shell command even if it is the current buffer. 3924 3925Other non-nil values prevent the output buffer from being erased; they 3926also reposition point in the shell output buffer after execution of the 3927shell command, except when the output buffer is the current buffer. 3928 3929The value `beg-last-out' sets point at the beginning of the last 3930output, `end-last-out' sets point at the end of the last output, 3931and `save-point' restores the buffer position as it was before the 3932shell command." 3933 :type '(choice 3934 (const :tag "Erase output buffer if not the current one" nil) 3935 (const :tag "Always erase output buffer" erase) 3936 (const :tag "Set point to beginning of last output" beg-last-out) 3937 (const :tag "Set point to end of last output" end-last-out) 3938 (const :tag "Save point" save-point)) 3939 :group 'shell 3940 :version "27.1") 3941 3942(defvar shell-command-saved-pos nil 3943 "Record of point positions in output buffers after command completion. 3944The value is an alist whose elements are of the form (BUFFER . POS), 3945where BUFFER is the output buffer, and POS is the point position 3946in BUFFER once the command finishes. 3947This variable is used when `shell-command-dont-erase-buffer' is non-nil.") 3948 3949(defun shell-command-save-pos-or-erase (&optional output-to-current-buffer) 3950 "Store a buffer position or erase the buffer. 3951Optional argument OUTPUT-TO-CURRENT-BUFFER, if non-nil, means that the output 3952of the shell command goes to the caller current buffer. 3953 3954See `shell-command-dont-erase-buffer'." 3955 (let ((sym shell-command-dont-erase-buffer) 3956 pos) 3957 (setq buffer-read-only nil) 3958 ;; Setting buffer-read-only to nil doesn't suffice 3959 ;; if some text has a non-nil read-only property, 3960 ;; which comint sometimes adds for prompts. 3961 (setq pos 3962 (cond ((eq sym 'save-point) 3963 (if (not output-to-current-buffer) 3964 (point))) 3965 ((eq sym 'beg-last-out) 3966 (if (not output-to-current-buffer) 3967 (point-max))) 3968 ((or (eq sym 'erase) 3969 (and (null sym) (not output-to-current-buffer))) 3970 (let ((inhibit-read-only t)) 3971 (erase-buffer) nil)))) 3972 (when pos 3973 (goto-char (point-max)) 3974 (push (cons (current-buffer) pos) 3975 shell-command-saved-pos)))) 3976 3977(defun shell-command-set-point-after-cmd (&optional buffer) 3978 "Set point in BUFFER after command complete. 3979BUFFER is the output buffer of the command; if nil, then defaults 3980to the current BUFFER. 3981Set point to the `cdr' of the element in `shell-command-saved-pos' 3982whose `car' is BUFFER." 3983 (when shell-command-dont-erase-buffer 3984 (let* ((sym shell-command-dont-erase-buffer) 3985 (buf (or buffer (current-buffer))) 3986 (pos (alist-get buf shell-command-saved-pos))) 3987 (setq shell-command-saved-pos 3988 (assq-delete-all buf shell-command-saved-pos)) 3989 (when (buffer-live-p buf) 3990 (let ((win (car (get-buffer-window-list buf))) 3991 (pmax (with-current-buffer buf (point-max)))) 3992 3993 ;; The first time we run a command in a freshly created buffer 3994 ;; we have not saved positions yet; advance to `point-max', so that 3995 ;; successive commands know where to start. 3996 (unless (and pos (memq sym '(save-point beg-last-out end-last-out))) 3997 (setq pos pmax)) 3998 ;; Set point in the window displaying buf, if any; otherwise 3999 ;; display buf temporary in selected frame and set the point. 4000 (if win 4001 (set-window-point win pos) 4002 (when pos 4003 (with-current-buffer buf (goto-char pos))) 4004 (save-window-excursion 4005 (let ((win (display-buffer 4006 buf 4007 '(nil (inhibit-switch-frame . t))))) 4008 (set-window-point win pos))))))))) 4009 4010(defun async-shell-command (command &optional output-buffer error-buffer) 4011 "Execute string COMMAND asynchronously in background. 4012 4013Like `shell-command', but adds `&' at the end of COMMAND 4014to execute it asynchronously. 4015 4016The output appears in the buffer whose name is stored in the 4017variable `shell-command-buffer-name-async'. That buffer is in 4018shell mode. 4019 4020You can configure `async-shell-command-buffer' to specify what to do 4021when the buffer specified by `shell-command-buffer-name-async' is 4022already taken by another running shell command. 4023 4024To run COMMAND without displaying the output in a window you can 4025configure `display-buffer-alist' to use the action 4026`display-buffer-no-window' for the buffer given by 4027`shell-command-buffer-name-async'. 4028 4029In Elisp, you will often be better served by calling `start-process' 4030directly, since it offers more control and does not impose the use of 4031a shell (with its need to quote arguments)." 4032 (interactive 4033 (list 4034 (read-shell-command (if shell-command-prompt-show-cwd 4035 (format-message "Async shell command in `%s': " 4036 (abbreviate-file-name 4037 default-directory)) 4038 "Async shell command: ") 4039 nil nil 4040 (let ((filename 4041 (cond 4042 (buffer-file-name) 4043 ((eq major-mode 'dired-mode) 4044 (dired-get-filename nil t))))) 4045 (and filename (file-relative-name filename)))) 4046 current-prefix-arg 4047 shell-command-default-error-buffer)) 4048 (unless (string-match "&[ \t]*\\'" command) 4049 (setq command (concat command " &"))) 4050 (shell-command command output-buffer error-buffer)) 4051 4052(declare-function comint-output-filter "comint" (process string)) 4053(declare-function comint-term-environment "comint" ()) 4054 4055(defun shell-command (command &optional output-buffer error-buffer) 4056 "Execute string COMMAND in inferior shell; display output, if any. 4057With prefix argument, insert the COMMAND's output at point. 4058 4059Interactively, prompt for COMMAND in the minibuffer. 4060If `shell-command-prompt-show-cwd' is non-nil, show the current 4061directory in the prompt. 4062 4063If COMMAND ends in `&', execute it asynchronously. 4064The output appears in the buffer whose name is specified 4065by `shell-command-buffer-name-async'. That buffer is in shell 4066mode. You can also use `async-shell-command' that automatically 4067adds `&'. 4068 4069Otherwise, COMMAND is executed synchronously. The output appears in 4070the buffer named by `shell-command-buffer-name'. If the output is 4071short enough to display in the echo area (which is determined by the 4072variables `resize-mini-windows' and `max-mini-window-height'), it is 4073shown there, but it is nonetheless available in buffer named by 4074`shell-command-buffer-name' even though that buffer is not 4075automatically displayed. 4076 4077To specify a coding system for converting non-ASCII characters 4078in the shell command output, use \\[universal-coding-system-argument] \ 4079before this command. 4080 4081Noninteractive callers can specify coding systems by binding 4082`coding-system-for-read' and `coding-system-for-write'. 4083 4084The optional second argument OUTPUT-BUFFER, if non-nil, 4085says to put the output in some other buffer. 4086If OUTPUT-BUFFER is a buffer or buffer name, erase that buffer 4087and insert the output there; a non-nil value of 4088`shell-command-dont-erase-buffer' prevents the buffer from being 4089erased. If OUTPUT-BUFFER is not a buffer and not nil (which happens 4090interactively when the prefix argument is given), insert the 4091output in current buffer after point leaving mark after it. This 4092cannot be done asynchronously. 4093 4094The user option `shell-command-dont-erase-buffer', which see, controls 4095whether the output buffer is erased and where to put point after 4096the shell command. 4097 4098If the command terminates without error, but generates output, 4099and you did not specify \"insert it in the current buffer\", 4100the output can be displayed in the echo area or in its buffer. 4101If the output is short enough to display in the echo area 4102\(determined by the variable `max-mini-window-height' if 4103`resize-mini-windows' is non-nil), it is shown there. 4104Otherwise, the buffer containing the output is displayed. 4105 4106If there is output and an error, and you did not specify \"insert it 4107in the current buffer\", a message about the error goes at the end 4108of the output. 4109 4110If the optional third argument ERROR-BUFFER is non-nil, it is a buffer 4111or buffer name to which to direct the command's standard error output. 4112If it is nil, error output is mingled with regular output. 4113In an interactive call, the variable `shell-command-default-error-buffer' 4114specifies the value of ERROR-BUFFER. 4115 4116In Elisp, you will often be better served by calling `call-process' or 4117`start-process' directly, since they offer more control and do not 4118impose the use of a shell (with its need to quote arguments)." 4119 4120 (interactive 4121 (list 4122 (read-shell-command (if shell-command-prompt-show-cwd 4123 (format-message "Shell command in `%s': " 4124 (abbreviate-file-name 4125 default-directory)) 4126 "Shell command: ") 4127 nil nil 4128 (let ((filename 4129 (cond 4130 (buffer-file-name) 4131 ((eq major-mode 'dired-mode) 4132 (dired-get-filename nil t))))) 4133 (and filename (file-relative-name filename)))) 4134 current-prefix-arg 4135 shell-command-default-error-buffer)) 4136 ;; Look for a handler in case default-directory is a remote file name. 4137 (let ((handler 4138 (find-file-name-handler (directory-file-name default-directory) 4139 'shell-command))) 4140 (if handler 4141 (funcall handler 'shell-command command output-buffer error-buffer) 4142 (if (and output-buffer 4143 (not (string-match "[ \t]*&[ \t]*\\'" command)) 4144 (or (eq output-buffer (current-buffer)) 4145 (and (stringp output-buffer) (eq (get-buffer output-buffer) (current-buffer))) 4146 (not (or (bufferp output-buffer) (stringp output-buffer))))) ; Bug#39067 4147 ;; Synchronous command with output in current buffer. 4148 (let ((error-file 4149 (and error-buffer 4150 (make-temp-file 4151 (expand-file-name "scor" 4152 (or small-temporary-file-directory 4153 temporary-file-directory)))))) 4154 (barf-if-buffer-read-only) 4155 (push-mark nil t) 4156 (shell-command-save-pos-or-erase 'output-to-current-buffer) 4157 ;; We do not use -f for csh; we will not support broken use of 4158 ;; .cshrcs. Even the BSD csh manual says to use 4159 ;; "if ($?prompt) exit" before things that are not useful 4160 ;; non-interactively. Besides, if someone wants their other 4161 ;; aliases for shell commands then they can still have them. 4162 (call-process-shell-command command nil (if error-file 4163 (list t error-file) 4164 t)) 4165 (when (and error-file (file-exists-p error-file)) 4166 (when (< 0 (file-attribute-size (file-attributes error-file))) 4167 (with-current-buffer (get-buffer-create error-buffer) 4168 (let ((pos-from-end (- (point-max) (point)))) 4169 (or (bobp) 4170 (insert "\f\n")) 4171 ;; Do no formatting while reading error file, 4172 ;; because that can run a shell command, and we 4173 ;; don't want that to cause an infinite recursion. 4174 (format-insert-file error-file nil) 4175 ;; Put point after the inserted errors. 4176 (goto-char (- (point-max) pos-from-end))) 4177 (display-buffer (current-buffer)))) 4178 (delete-file error-file)) 4179 ;; This is like exchange-point-and-mark, but doesn't 4180 ;; activate the mark. It is cleaner to avoid activation, 4181 ;; even though the command loop would deactivate the mark 4182 ;; because we inserted text. 4183 (goto-char (prog1 (mark t) 4184 (set-marker (mark-marker) (point) 4185 (current-buffer))))) 4186 ;; Output goes in a separate buffer. 4187 ;; Preserve the match data in case called from a program. 4188 ;; FIXME: It'd be ridiculous for an Elisp function to call 4189 ;; shell-command and assume that it won't mess the match-data! 4190 (save-match-data 4191 (if (string-match "[ \t]*&[ \t]*\\'" command) 4192 ;; Command ending with ampersand means asynchronous. 4193 (let* ((buffer (get-buffer-create 4194 (or output-buffer shell-command-buffer-name-async))) 4195 (bname (buffer-name buffer)) 4196 (proc (get-buffer-process buffer)) 4197 (directory default-directory)) 4198 ;; Remove the ampersand. 4199 (setq command (substring command 0 (match-beginning 0))) 4200 ;; Ask the user what to do with already running process. 4201 (when proc 4202 (cond 4203 ((eq async-shell-command-buffer 'confirm-kill-process) 4204 ;; If will kill a process, query first. 4205 (if (yes-or-no-p "A command is running in the default buffer. Kill it? ") 4206 (kill-process proc) 4207 (user-error "Shell command in progress"))) 4208 ((eq async-shell-command-buffer 'confirm-new-buffer) 4209 ;; If will create a new buffer, query first. 4210 (if (yes-or-no-p "A command is running in the default buffer. Use a new buffer? ") 4211 (setq buffer (generate-new-buffer bname)) 4212 (user-error "Shell command in progress"))) 4213 ((eq async-shell-command-buffer 'new-buffer) 4214 ;; It will create a new buffer. 4215 (setq buffer (generate-new-buffer bname))) 4216 ((eq async-shell-command-buffer 'confirm-rename-buffer) 4217 ;; If will rename the buffer, query first. 4218 (if (yes-or-no-p "A command is running in the default buffer. Rename it? ") 4219 (progn 4220 (with-current-buffer buffer 4221 (rename-uniquely)) 4222 (setq buffer (get-buffer-create bname))) 4223 (user-error "Shell command in progress"))) 4224 ((eq async-shell-command-buffer 'rename-buffer) 4225 ;; It will rename the buffer. 4226 (with-current-buffer buffer 4227 (rename-uniquely)) 4228 (setq buffer (get-buffer-create bname))))) 4229 (with-current-buffer buffer 4230 (shell-command-save-pos-or-erase) 4231 (setq default-directory directory) 4232 (require 'shell) 4233 (let ((process-environment 4234 (append 4235 (and (natnump async-shell-command-width) 4236 (list 4237 (format "COLUMNS=%d" 4238 async-shell-command-width))) 4239 (comint-term-environment) 4240 process-environment))) 4241 (setq proc 4242 (start-process-shell-command "Shell" buffer command))) 4243 (setq mode-line-process '(":%s")) 4244 (shell-mode) 4245 (setq-local revert-buffer-function 4246 (lambda (&rest _) 4247 (async-shell-command command buffer))) 4248 (set-process-sentinel proc #'shell-command-sentinel) 4249 ;; Use the comint filter for proper handling of 4250 ;; carriage motion (see comint-inhibit-carriage-motion). 4251 (set-process-filter proc #'comint-output-filter) 4252 (if async-shell-command-display-buffer 4253 ;; Display buffer immediately. 4254 (display-buffer buffer '(nil (allow-no-window . t))) 4255 ;; Defer displaying buffer until first process output. 4256 ;; Use disposable named advice so that the buffer is 4257 ;; displayed at most once per process lifetime. 4258 (let ((nonce (make-symbol "nonce"))) 4259 (add-function :before (process-filter proc) 4260 (lambda (proc _string) 4261 (let ((buf (process-buffer proc))) 4262 (when (buffer-live-p buf) 4263 (remove-function (process-filter proc) 4264 nonce) 4265 (display-buffer buf)))) 4266 `((name . ,nonce))))))) 4267 ;; Otherwise, command is executed synchronously. 4268 (shell-command-on-region (point) (point) command 4269 output-buffer nil error-buffer))))))) 4270 4271(defun max-mini-window-lines (&optional frame) 4272 "Compute maximum number of lines for echo area in FRAME. 4273As defined by `max-mini-window-height'. FRAME defaults to the 4274selected frame. Result may be a floating-point number, 4275i.e. include a fractional number of lines." 4276 (cond ((floatp max-mini-window-height) (* (frame-height frame) 4277 max-mini-window-height)) 4278 ((integerp max-mini-window-height) max-mini-window-height) 4279 (t 1))) 4280 4281(defun display-message-or-buffer (message &optional buffer-name action frame) 4282 "Display MESSAGE in the echo area if possible, otherwise in a pop-up buffer. 4283MESSAGE may be either a string or a buffer. 4284 4285A pop-up buffer is displayed using `display-buffer' if MESSAGE is too long 4286for maximum height of the echo area, as defined by `max-mini-window-lines' 4287if `resize-mini-windows' is non-nil. 4288 4289Returns either the string shown in the echo area, or when a pop-up 4290buffer is used, the window used to display it. 4291 4292If MESSAGE is a string, then the optional argument BUFFER-NAME is the 4293name of the buffer used to display it in the case where a pop-up buffer 4294is used, defaulting to `*Message*'. In the case where MESSAGE is a 4295string and it is displayed in the echo area, it is not specified whether 4296the contents are inserted into the buffer anyway. 4297 4298Optional arguments ACTION and FRAME are as for `display-buffer', 4299and are used only if a pop-up buffer is displayed." 4300 (cond ((and (stringp message) (not (string-search "\n" message))) 4301 ;; Trivial case where we can use the echo area 4302 (message "%s" message)) 4303 ((and (stringp message) 4304 (= (string-search "\n" message) (1- (length message)))) 4305 ;; Trivial case where we can just remove single trailing newline 4306 (message "%s" (substring message 0 (1- (length message))))) 4307 (t 4308 ;; General case 4309 (with-current-buffer 4310 (if (bufferp message) 4311 message 4312 (get-buffer-create (or buffer-name "*Message*"))) 4313 4314 (unless (bufferp message) 4315 (erase-buffer) 4316 (insert message)) 4317 4318 (let ((lines 4319 (if (= (buffer-size) 0) 4320 0 4321 (count-screen-lines nil nil nil (minibuffer-window))))) 4322 (cond ((= lines 0)) 4323 ((and (or (<= lines 1) 4324 (<= lines 4325 (if resize-mini-windows (max-mini-window-lines) 4326 1))) 4327 ;; Don't use the echo area if the output buffer is 4328 ;; already displayed in the selected frame. 4329 (not (get-buffer-window (current-buffer)))) 4330 ;; Echo area 4331 (goto-char (point-max)) 4332 (when (bolp) 4333 (backward-char 1)) 4334 (message "%s" (buffer-substring (point-min) (point)))) 4335 (t 4336 ;; Buffer 4337 (goto-char (point-min)) 4338 (display-buffer (current-buffer) action frame)))))))) 4339 4340 4341;; We have a sentinel to prevent insertion of a termination message 4342;; in the buffer itself, and to set the point in the buffer when 4343;; `shell-command-dont-erase-buffer' is non-nil. 4344(defun shell-command-sentinel (process signal) 4345 (when (memq (process-status process) '(exit signal)) 4346 (shell-command-set-point-after-cmd (process-buffer process)) 4347 (message "%s: %s." 4348 (car (cdr (cdr (process-command process)))) 4349 (substring signal 0 -1)))) 4350 4351(defun shell-command-on-region (start end command 4352 &optional output-buffer replace 4353 error-buffer display-error-buffer 4354 region-noncontiguous-p) 4355 "Execute string COMMAND in inferior shell with region as input. 4356Normally display output (if any) in temp buffer specified 4357by `shell-command-buffer-name'; prefix arg means replace the region 4358with it. Return the exit code of COMMAND. 4359 4360To specify a coding system for converting non-ASCII characters 4361in the input and output to the shell command, use \\[universal-coding-system-argument] 4362before this command. By default, the input (from the current buffer) 4363is encoded using coding-system specified by `process-coding-system-alist', 4364falling back to `default-process-coding-system' if no match for COMMAND 4365is found in `process-coding-system-alist'. 4366 4367Noninteractive callers can specify coding systems by binding 4368`coding-system-for-read' and `coding-system-for-write'. 4369 4370If the command generates output, the output may be displayed 4371in the echo area or in a buffer. 4372If the output is short enough to display in the echo area 4373\(determined by the variable `max-mini-window-height' if 4374`resize-mini-windows' is non-nil), it is shown there. 4375Otherwise it is displayed in the buffer named by `shell-command-buffer-name'. 4376The output is available in that buffer in both cases. 4377 4378If there is output and an error, a message about the error 4379appears at the end of the output. 4380 4381Optional fourth arg OUTPUT-BUFFER specifies where to put the 4382command's output. If the value is a buffer or buffer name, 4383erase that buffer and insert the output there; a non-nil value of 4384`shell-command-dont-erase-buffer' prevent to erase the buffer. 4385If the value is nil, use the buffer specified by `shell-command-buffer-name'. 4386Any other non-nil value means to insert the output in the 4387current buffer after START. 4388 4389Optional fifth arg REPLACE, if non-nil, means to insert the 4390output in place of text from START to END, putting point and mark 4391around it. If REPLACE is the symbol `no-mark', don't set the mark. 4392 4393Optional sixth arg ERROR-BUFFER, if non-nil, specifies a buffer 4394or buffer name to which to direct the command's standard error 4395output. If nil, error output is mingled with regular output. 4396When called interactively, `shell-command-default-error-buffer' 4397is used for ERROR-BUFFER. 4398 4399Optional seventh arg DISPLAY-ERROR-BUFFER, if non-nil, means to 4400display the error buffer if there were any errors. When called 4401interactively, this is t. 4402 4403Non-nil REGION-NONCONTIGUOUS-P means that the region is composed of 4404noncontiguous pieces. The most common example of this is a 4405rectangular region, where the pieces are separated by newline 4406characters." 4407 (interactive (let (string) 4408 (unless (mark) 4409 (user-error "The mark is not set now, so there is no region")) 4410 ;; Do this before calling region-beginning 4411 ;; and region-end, in case subprocess output 4412 ;; relocates them while we are in the minibuffer. 4413 (setq string (read-shell-command "Shell command on region: ")) 4414 ;; call-interactively recognizes region-beginning and 4415 ;; region-end specially, leaving them in the history. 4416 (list (region-beginning) (region-end) 4417 string 4418 current-prefix-arg 4419 current-prefix-arg 4420 shell-command-default-error-buffer 4421 t 4422 (region-noncontiguous-p)))) 4423 (let ((error-file 4424 (if error-buffer 4425 (make-temp-file 4426 (expand-file-name "scor" 4427 (or small-temporary-file-directory 4428 temporary-file-directory))) 4429 nil)) 4430 exit-status) 4431 ;; Unless a single contiguous chunk is selected, operate on multiple chunks. 4432 (if region-noncontiguous-p 4433 (let ((input (concat (funcall region-extract-function (when replace 'delete)) "\n")) 4434 output) 4435 (with-temp-buffer 4436 (insert input) 4437 (call-process-region (point-min) (point-max) 4438 shell-file-name t t 4439 nil shell-command-switch 4440 command) 4441 (setq output (split-string (buffer-substring 4442 (point-min) 4443 ;; Trim the trailing newline. 4444 (if (eq (char-before (point-max)) ?\n) 4445 (1- (point-max)) 4446 (point-max))) 4447 "\n"))) 4448 (cond 4449 (replace 4450 (goto-char start) 4451 (funcall region-insert-function output)) 4452 (t 4453 (let ((buffer (get-buffer-create 4454 (or output-buffer shell-command-buffer-name)))) 4455 (with-current-buffer buffer 4456 (erase-buffer) 4457 (funcall region-insert-function output)) 4458 (display-message-or-buffer buffer))))) 4459 (if (or replace 4460 (and output-buffer 4461 (not (or (bufferp output-buffer) (stringp output-buffer))))) 4462 ;; Replace specified region with output from command. 4463 (let ((swap (and replace (< start end)))) 4464 ;; Don't muck with mark unless REPLACE says we should. 4465 (goto-char start) 4466 (when (and replace 4467 (not (eq replace 'no-mark))) 4468 (push-mark (point) 'nomsg)) 4469 (setq exit-status 4470 (call-shell-region start end command replace 4471 (if error-file 4472 (list t error-file) 4473 t))) 4474 ;; It is rude to delete a buffer that the command is not using. 4475 ;; (let ((shell-buffer (get-buffer shell-command-buffer-name))) 4476 ;; (and shell-buffer (not (eq shell-buffer (current-buffer))) 4477 ;; (kill-buffer shell-buffer))) 4478 ;; Don't muck with mark unless REPLACE says we should. 4479 (when (and replace swap 4480 (not (eq replace 'no-mark))) 4481 (exchange-point-and-mark))) 4482 ;; No prefix argument: put the output in a temp buffer, 4483 ;; replacing its entire contents. 4484 (let ((buffer (get-buffer-create 4485 (or output-buffer shell-command-buffer-name)))) 4486 (set-buffer-major-mode buffer) ; Enable globalized modes (bug#38111) 4487 (unwind-protect 4488 (if (and (eq buffer (current-buffer)) 4489 (or (memq shell-command-dont-erase-buffer '(nil erase)) 4490 (and (not (eq buffer (get-buffer 4491 shell-command-buffer-name))) 4492 (not (region-active-p))))) 4493 ;; If the input is the same buffer as the output, 4494 ;; delete everything but the specified region, 4495 ;; then replace that region with the output. 4496 (progn (setq buffer-read-only nil) 4497 (delete-region (max start end) (point-max)) 4498 (delete-region (point-min) (min start end)) 4499 (setq exit-status 4500 (call-process-region (point-min) (point-max) 4501 shell-file-name t 4502 (if error-file 4503 (list t error-file) 4504 t) 4505 nil shell-command-switch 4506 command))) 4507 ;; Clear the output buffer, then run the command with 4508 ;; output there. 4509 (let ((directory default-directory)) 4510 (with-current-buffer buffer 4511 (if (not output-buffer) 4512 (setq default-directory directory)) 4513 (shell-command-save-pos-or-erase))) 4514 (setq exit-status 4515 (call-shell-region start end command nil 4516 (if error-file 4517 (list buffer error-file) 4518 buffer)))) 4519 ;; Report the output. 4520 (with-current-buffer buffer 4521 (setq-local revert-buffer-function 4522 (lambda (&rest _) 4523 (shell-command command))) 4524 (setq mode-line-process 4525 (cond ((null exit-status) 4526 " - Error") 4527 ((stringp exit-status) 4528 (format " - Signal [%s]" exit-status)) 4529 ((not (equal 0 exit-status)) 4530 (format " - Exit [%d]" exit-status))))) 4531 (if (with-current-buffer buffer (> (point-max) (point-min))) 4532 ;; There's some output, display it 4533 (progn 4534 (display-message-or-buffer buffer) 4535 (shell-command-set-point-after-cmd buffer)) 4536 ;; No output; error? 4537 (let ((output 4538 (if (and error-file 4539 (< 0 (file-attribute-size 4540 (file-attributes error-file)))) 4541 (format "some error output%s" 4542 (if shell-command-default-error-buffer 4543 (format " to the \"%s\" buffer" 4544 shell-command-default-error-buffer) 4545 "")) 4546 "no output"))) 4547 (cond ((null exit-status) 4548 (message "(Shell command failed with error)")) 4549 ((equal 0 exit-status) 4550 (message "(Shell command succeeded with %s)" 4551 output)) 4552 ((stringp exit-status) 4553 (message "(Shell command killed by signal %s)" 4554 exit-status)) 4555 (t 4556 (message "(Shell command failed with code %d and %s)" 4557 exit-status output)))) 4558 ;; Don't kill: there might be useful info in the undo-log. 4559 ;; (kill-buffer buffer) 4560 ))))) 4561 4562 (when (and error-file (file-exists-p error-file)) 4563 (if (< 0 (file-attribute-size (file-attributes error-file))) 4564 (with-current-buffer (get-buffer-create error-buffer) 4565 (goto-char (point-max)) 4566 ;; Insert a separator if there's already text here. 4567 (unless (bobp) 4568 (insert "\f\n")) 4569 ;; Do no formatting while reading error file, 4570 ;; because that can run a shell command, and we 4571 ;; don't want that to cause an infinite recursion. 4572 (format-insert-file error-file nil) 4573 (and display-error-buffer 4574 (display-buffer (current-buffer))))) 4575 (delete-file error-file)) 4576 exit-status)) 4577 4578(defun shell-command-to-string (command) 4579 "Execute shell command COMMAND and return its output as a string." 4580 (with-output-to-string 4581 (with-current-buffer standard-output 4582 (shell-command command t)))) 4583 4584(defun process-file (program &optional infile buffer display &rest args) 4585 "Process files synchronously in a separate process that runs PROGRAM. 4586Similar to `call-process', but may invoke a file name handler based on 4587`default-directory'. The current working directory of the 4588subprocess is `default-directory'. 4589 4590If PROGRAM is a remote file name, it should be processed 4591by `file-local-name' before passing it to this function. 4592 4593Handle file names in INFILE and BUFFER normally; this differs 4594from `call-process', which does not support file name handlers 4595for INFILE and BUFFER. However, pass ARGS to the process 4596verbatim without file name handling, as `call-process' does. 4597 4598Some file name handlers might not support all variants. For 4599example, they might treat DISPLAY as nil regardless of the actual 4600value passed." 4601 (let ((fh (find-file-name-handler default-directory 'process-file)) 4602 lc stderr-file) 4603 (unwind-protect 4604 (if fh (apply fh 'process-file program infile buffer display args) 4605 (when infile (setq lc (file-local-copy infile))) 4606 (setq stderr-file (when (and (consp buffer) (stringp (cadr buffer))) 4607 (make-temp-file "emacs"))) 4608 (prog1 4609 (apply 'call-process program 4610 (or lc infile) 4611 (if stderr-file (list (car buffer) stderr-file) buffer) 4612 display args) 4613 (when stderr-file (copy-file stderr-file (cadr buffer) t)))) 4614 (when stderr-file (delete-file stderr-file)) 4615 (when lc (delete-file lc))))) 4616 4617(defvar process-file-side-effects t 4618 "Whether a call of `process-file' changes remote files. 4619 4620By default, this variable is always set to t, meaning that a 4621call of `process-file' could potentially change any file on a 4622remote host. When set to nil, a file name handler could optimize 4623its behavior with respect to remote file attribute caching. 4624 4625You should only ever change this variable with a let-binding; 4626never with `setq'.") 4627 4628(defcustom process-file-return-signal-string nil 4629 "Whether to return a string describing the signal interrupting a process. 4630When a process returns an exit code greater than 128, it is 4631interpreted as a signal. `process-file' requires to return a 4632string describing this signal. 4633Since there are processes violating this rule, returning exit 4634codes greater than 128 which are not bound to a signal, 4635`process-file' returns the exit code as natural number also in 4636this case. Setting this user option to non-nil forces 4637`process-file' to interpret such exit codes as signals, and to 4638return a corresponding string." 4639 :version "28.1" 4640 :type 'boolean) 4641 4642(defun start-file-process (name buffer program &rest program-args) 4643 "Start a program in a subprocess. Return the process object for it. 4644 4645Similar to `start-process', but may invoke a file name handler based on 4646`default-directory'. See Info node `(elisp)Magic File Names'. 4647 4648This handler ought to run PROGRAM, perhaps on the local host, 4649perhaps on a remote host that corresponds to `default-directory'. 4650In the latter case, the local part of `default-directory', the one 4651produced from it by `file-local-name', becomes the working directory 4652of the process on the remote host. 4653 4654PROGRAM and PROGRAM-ARGS might be file names. They are not 4655objects of file name handler invocation, so they need to be obtained 4656by calling `file-local-name', in case they are remote file names. 4657 4658File name handlers might not support pty association, if PROGRAM is nil." 4659 (let ((fh (find-file-name-handler default-directory 'start-file-process))) 4660 (if fh (apply fh 'start-file-process name buffer program program-args) 4661 (apply 'start-process name buffer program program-args)))) 4662 4663;;;; Process menu 4664 4665(defvar tabulated-list-format) 4666(defvar tabulated-list-entries) 4667(defvar tabulated-list-sort-key) 4668(declare-function tabulated-list-init-header "tabulated-list" ()) 4669(declare-function tabulated-list-print "tabulated-list" 4670 (&optional remember-pos update)) 4671 4672(defvar process-menu-query-only nil) 4673 4674(defvar process-menu-mode-map 4675 (let ((map (make-sparse-keymap))) 4676 (define-key map [?d] 'process-menu-delete-process) 4677 map)) 4678 4679(define-derived-mode process-menu-mode tabulated-list-mode "Process Menu" 4680 "Major mode for listing the processes called by Emacs." 4681 (setq tabulated-list-format [("Process" 15 t) 4682 ("PID" 7 t) 4683 ("Status" 7 t) 4684 ;; 25 is the length of the long standard buffer 4685 ;; name "*Async Shell Command*<10>" (bug#30016) 4686 ("Buffer" 25 t) 4687 ("TTY" 12 t) 4688 ("Thread" 12 t) 4689 ("Command" 0 t)]) 4690 (make-local-variable 'process-menu-query-only) 4691 (setq tabulated-list-sort-key (cons "Process" nil)) 4692 (add-hook 'tabulated-list-revert-hook 'list-processes--refresh nil t)) 4693 4694(defun process-menu-delete-process () 4695 "Kill process at point in a `list-processes' buffer." 4696 (interactive) 4697 (let ((pos (point))) 4698 (delete-process (tabulated-list-get-id)) 4699 (revert-buffer) 4700 (goto-char (min pos (point-max))) 4701 (if (eobp) 4702 (forward-line -1) 4703 (beginning-of-line)))) 4704 4705(declare-function thread-name "thread.c") 4706 4707(defun list-processes--refresh () 4708 "Recompute the list of processes for the Process List buffer. 4709Also, delete any process that is exited or signaled." 4710 (setq tabulated-list-entries nil) 4711 (dolist (p (process-list)) 4712 (cond ((memq (process-status p) '(exit signal closed)) 4713 (delete-process p)) 4714 ((or (not process-menu-query-only) 4715 (process-query-on-exit-flag p)) 4716 (let* ((buf (process-buffer p)) 4717 (type (process-type p)) 4718 (pid (if (process-id p) (format "%d" (process-id p)) "--")) 4719 (name (process-name p)) 4720 (status (symbol-name (process-status p))) 4721 (buf-label (if (buffer-live-p buf) 4722 `(,(buffer-name buf) 4723 face link 4724 help-echo ,(format-message 4725 "Visit buffer `%s'" 4726 (buffer-name buf)) 4727 follow-link t 4728 process-buffer ,buf 4729 action process-menu-visit-buffer) 4730 "--")) 4731 (tty (or (process-tty-name p) "--")) 4732 (thread 4733 (cond 4734 ((or 4735 (null (process-thread p)) 4736 (not (fboundp 'thread-name))) "--") 4737 ((eq (process-thread p) main-thread) "Main") 4738 ((thread-name (process-thread p))) 4739 (t "--"))) 4740 (cmd 4741 (if (memq type '(network serial pipe)) 4742 (let ((contact (process-contact p t t))) 4743 (if (eq type 'network) 4744 (format "(%s %s)" 4745 (if (plist-get contact :type) 4746 "datagram" 4747 "network") 4748 (if (plist-get contact :server) 4749 (format 4750 "server on %s" 4751 (if (plist-get contact :host) 4752 (format "%s:%s" 4753 (plist-get contact :host) 4754 (plist-get 4755 contact :service)) 4756 (plist-get contact :local))) 4757 (format "connection to %s:%s" 4758 (plist-get contact :host) 4759 (plist-get contact :service)))) 4760 (format "(serial port %s%s)" 4761 (or (plist-get contact :port) "?") 4762 (let ((speed (plist-get contact :speed))) 4763 (if speed 4764 (format " at %s b/s" speed) 4765 ""))))) 4766 (mapconcat 'identity (process-command p) " ")))) 4767 (push (list p (vector name pid status buf-label tty thread cmd)) 4768 tabulated-list-entries))))) 4769 (tabulated-list-init-header)) 4770 4771(defun process-menu-visit-buffer (button) 4772 (display-buffer (button-get button 'process-buffer))) 4773 4774(defun list-processes (&optional query-only buffer) 4775 "Display a list of all processes that are Emacs sub-processes. 4776If optional argument QUERY-ONLY is non-nil, only processes with 4777the query-on-exit flag set are listed. 4778Any process listed as exited or signaled is actually eliminated 4779after the listing is made. 4780Optional argument BUFFER specifies a buffer to use, instead of 4781\"*Process List*\". 4782The return value is always nil. 4783 4784This function lists only processes that were launched by Emacs. To 4785see other processes running on the system, use `list-system-processes'." 4786 (interactive) 4787 (or (fboundp 'process-list) 4788 (error "Asynchronous subprocesses are not supported on this system")) 4789 (unless (bufferp buffer) 4790 (setq buffer (get-buffer-create "*Process List*"))) 4791 (with-current-buffer buffer 4792 (process-menu-mode) 4793 (setq process-menu-query-only query-only) 4794 (list-processes--refresh) 4795 (tabulated-list-print)) 4796 (display-buffer buffer) 4797 nil) 4798 4799;;;; Prefix commands 4800 4801(setq prefix-command--needs-update nil) 4802(setq prefix-command--last-echo nil) 4803 4804(defun internal-echo-keystrokes-prefix () 4805 ;; BEWARE: Called directly from C code. 4806 ;; If the return value is non-nil, it means we are in the middle of 4807 ;; a command with prefix, such as a command invoked with prefix-arg. 4808 (if (not prefix-command--needs-update) 4809 prefix-command--last-echo 4810 (setq prefix-command--last-echo 4811 (let ((strs nil)) 4812 (run-hook-wrapped 'prefix-command-echo-keystrokes-functions 4813 (lambda (fun) (push (funcall fun) strs) nil)) 4814 (setq strs (delq nil strs)) 4815 (when strs (mapconcat #'identity strs " ")))))) 4816 4817(defvar prefix-command-echo-keystrokes-functions nil 4818 "Abnormal hook that constructs the description of the current prefix state. 4819Each function is called with no argument, should return a string or nil.") 4820 4821(defun prefix-command-update () 4822 "Update state of prefix commands. 4823Call it whenever you change the \"prefix command state\"." 4824 (setq prefix-command--needs-update t)) 4825 4826(defvar prefix-command-preserve-state-hook nil 4827 "Normal hook run when a command needs to preserve the prefix.") 4828 4829(defun prefix-command-preserve-state () 4830 "Pass the current prefix command state to the next command. 4831Should be called by all prefix commands. 4832Runs `prefix-command-preserve-state-hook'." 4833 (run-hooks 'prefix-command-preserve-state-hook) 4834 ;; If the current command is a prefix command, we don't want the next (real) 4835 ;; command to have `last-command' set to, say, `universal-argument'. 4836 (setq this-command last-command) 4837 (setq real-this-command real-last-command) 4838 (prefix-command-update)) 4839 4840(defun reset-this-command-lengths () 4841 (declare (obsolete prefix-command-preserve-state "25.1")) 4842 nil) 4843 4844;;;;; The main prefix command. 4845 4846;; FIXME: Declaration of `prefix-arg' should be moved here!? 4847 4848(add-hook 'prefix-command-echo-keystrokes-functions 4849 #'universal-argument--description) 4850(defun universal-argument--description () 4851 (when prefix-arg 4852 (concat "C-u" 4853 (pcase prefix-arg 4854 ('(-) " -") 4855 (`(,(and (pred integerp) n)) 4856 (let ((str "")) 4857 (while (and (> n 4) (= (mod n 4) 0)) 4858 (setq str (concat str " C-u")) 4859 (setq n (/ n 4))) 4860 (if (= n 4) str (format " %s" prefix-arg)))) 4861 (_ (format " %s" prefix-arg)))))) 4862 4863(add-hook 'prefix-command-preserve-state-hook 4864 #'universal-argument--preserve) 4865(defun universal-argument--preserve () 4866 (setq prefix-arg current-prefix-arg)) 4867 4868(defvar universal-argument-map 4869 (let ((map (make-sparse-keymap)) 4870 (universal-argument-minus 4871 ;; For backward compatibility, minus with no modifiers is an ordinary 4872 ;; command if digits have already been entered. 4873 `(menu-item "" negative-argument 4874 :filter ,(lambda (cmd) 4875 (if (integerp prefix-arg) nil cmd))))) 4876 (define-key map [switch-frame] 4877 (lambda (e) (interactive "e") 4878 (handle-switch-frame e) (universal-argument--mode))) 4879 (define-key map [?\C-u] 'universal-argument-more) 4880 (define-key map [?-] universal-argument-minus) 4881 (define-key map [?0] 'digit-argument) 4882 (define-key map [?1] 'digit-argument) 4883 (define-key map [?2] 'digit-argument) 4884 (define-key map [?3] 'digit-argument) 4885 (define-key map [?4] 'digit-argument) 4886 (define-key map [?5] 'digit-argument) 4887 (define-key map [?6] 'digit-argument) 4888 (define-key map [?7] 'digit-argument) 4889 (define-key map [?8] 'digit-argument) 4890 (define-key map [?9] 'digit-argument) 4891 (define-key map [kp-0] 'digit-argument) 4892 (define-key map [kp-1] 'digit-argument) 4893 (define-key map [kp-2] 'digit-argument) 4894 (define-key map [kp-3] 'digit-argument) 4895 (define-key map [kp-4] 'digit-argument) 4896 (define-key map [kp-5] 'digit-argument) 4897 (define-key map [kp-6] 'digit-argument) 4898 (define-key map [kp-7] 'digit-argument) 4899 (define-key map [kp-8] 'digit-argument) 4900 (define-key map [kp-9] 'digit-argument) 4901 (define-key map [kp-subtract] universal-argument-minus) 4902 map) 4903 "Keymap used while processing \\[universal-argument].") 4904 4905(defun universal-argument--mode () 4906 (prefix-command-update) 4907 (set-transient-map universal-argument-map nil)) 4908 4909(defun universal-argument () 4910 "Begin a numeric argument for the following command. 4911Digits or minus sign following \\[universal-argument] make up the numeric argument. 4912\\[universal-argument] following the digits or minus sign ends the argument. 4913\\[universal-argument] without digits or minus sign provides 4 as argument. 4914Repeating \\[universal-argument] without digits or minus sign 4915 multiplies the argument by 4 each time. 4916For some commands, just \\[universal-argument] by itself serves as a flag 4917that is different in effect from any particular numeric argument. 4918These commands include \\[set-mark-command] and \\[start-kbd-macro]." 4919 (interactive) 4920 (prefix-command-preserve-state) 4921 (setq prefix-arg (list 4)) 4922 (universal-argument--mode)) 4923 4924(defun universal-argument-more (arg) 4925 ;; A subsequent C-u means to multiply the factor by 4 if we've typed 4926 ;; nothing but C-u's; otherwise it means to terminate the prefix arg. 4927 (interactive "P") 4928 (prefix-command-preserve-state) 4929 (setq prefix-arg (if (consp arg) 4930 (list (* 4 (car arg))) 4931 (if (eq arg '-) 4932 (list -4) 4933 arg))) 4934 (when (consp prefix-arg) (universal-argument--mode))) 4935 4936(defun negative-argument (arg) 4937 "Begin a negative numeric argument for the next command. 4938\\[universal-argument] following digits or minus sign ends the argument." 4939 (interactive "P") 4940 (prefix-command-preserve-state) 4941 (setq prefix-arg (cond ((integerp arg) (- arg)) 4942 ((eq arg '-) nil) 4943 (t '-))) 4944 (universal-argument--mode)) 4945 4946(defun digit-argument (arg) 4947 "Part of the numeric argument for the next command. 4948\\[universal-argument] following digits or minus sign ends the argument." 4949 (interactive "P") 4950 (prefix-command-preserve-state) 4951 (let* ((char (if (integerp last-command-event) 4952 last-command-event 4953 (get last-command-event 'ascii-character))) 4954 (digit (- (logand char ?\177) ?0))) 4955 (setq prefix-arg (cond ((integerp arg) 4956 (+ (* arg 10) 4957 (if (< arg 0) (- digit) digit))) 4958 ((eq arg '-) 4959 ;; Treat -0 as just -, so that -01 will work. 4960 (if (zerop digit) '- (- digit))) 4961 (t 4962 digit)))) 4963 (universal-argument--mode)) 4964 4965 4966(defvar filter-buffer-substring-functions nil 4967 "This variable is a wrapper hook around `buffer-substring--filter'. 4968\(See `with-wrapper-hook' for details about wrapper hooks.)") 4969(make-obsolete-variable 'filter-buffer-substring-functions 4970 'filter-buffer-substring-function "24.4") 4971 4972(defvar filter-buffer-substring-function #'buffer-substring--filter 4973 "Function to perform the filtering in `filter-buffer-substring'. 4974The function is called with the same 3 arguments (BEG END DELETE) 4975that `filter-buffer-substring' received. It should return the 4976buffer substring between BEG and END, after filtering. If DELETE is 4977non-nil, it should delete the text between BEG and END from the buffer.") 4978 4979(defvar buffer-substring-filters nil 4980 "List of filter functions for `buffer-substring--filter'. 4981Each function must accept a single argument, a string, and return a string. 4982The buffer substring is passed to the first function in the list, 4983and the return value of each function is passed to the next. 4984As a special convention, point is set to the start of the buffer text 4985being operated on (i.e., the first argument of `buffer-substring--filter') 4986before these functions are called.") 4987(make-obsolete-variable 'buffer-substring-filters 4988 'filter-buffer-substring-function "24.1") 4989 4990(defun filter-buffer-substring (beg end &optional delete) 4991 "Return the buffer substring between BEG and END, after filtering. 4992If DELETE is non-nil, delete the text between BEG and END from the buffer. 4993 4994This calls the function that `filter-buffer-substring-function' specifies 4995\(passing the same three arguments that it received) to do the work, 4996and returns whatever it does. The default function does no filtering, 4997unless a hook has been set. 4998 4999Use `filter-buffer-substring' instead of `buffer-substring', 5000`buffer-substring-no-properties', or `delete-and-extract-region' when 5001you want to allow filtering to take place. For example, major or minor 5002modes can use `filter-buffer-substring-function' to exclude text properties 5003that are special to a buffer, and should not be copied into other buffers." 5004 (funcall filter-buffer-substring-function beg end delete)) 5005 5006(defun buffer-substring--filter (beg end &optional delete) 5007 "Default function to use for `filter-buffer-substring-function'. 5008Its arguments and return value are as specified for `filter-buffer-substring'. 5009Also respects the obsolete wrapper hook `filter-buffer-substring-functions' 5010\(see `with-wrapper-hook' for details about wrapper hooks), 5011and the abnormal hook `buffer-substring-filters'. 5012No filtering is done unless a hook says to." 5013 (subr--with-wrapper-hook-no-warnings 5014 filter-buffer-substring-functions (beg end delete) 5015 (cond 5016 ((or delete buffer-substring-filters) 5017 (save-excursion 5018 (goto-char beg) 5019 (let ((string (if delete (delete-and-extract-region beg end) 5020 (buffer-substring beg end)))) 5021 (dolist (filter buffer-substring-filters) 5022 (setq string (funcall filter string))) 5023 string))) 5024 (t 5025 (buffer-substring beg end))))) 5026 5027 5028;;;; Window system cut and paste hooks. 5029 5030(defvar interprogram-cut-function #'gui-select-text 5031 "Function to call to make a killed region available to other programs. 5032Most window systems provide a facility for cutting and pasting 5033text between different programs, such as the clipboard on X and 5034MS-Windows, or the pasteboard on Nextstep/Mac OS. 5035 5036This variable holds a function that Emacs calls whenever text is 5037put in the kill ring, to make the new kill available to other 5038programs. The function takes one argument, TEXT, which is a 5039string containing the text that should be made available.") 5040 5041(defvar interprogram-paste-function #'gui-selection-value 5042 "Function to call to get text cut from other programs. 5043Most window systems provide a facility for cutting and pasting 5044text between different programs, such as the clipboard on X and 5045MS-Windows, or the pasteboard on Nextstep/Mac OS. 5046 5047This variable holds a function that Emacs calls to obtain text 5048that other programs have provided for pasting. The function is 5049called with no arguments. If no other program has provided text 5050to paste, the function should return nil (in which case the 5051caller, usually `current-kill', should use the top of the Emacs 5052kill ring). If another program has provided text to paste, the 5053function should return that text as a string (in which case the 5054caller should put this string in the kill ring as the latest 5055kill). 5056 5057The function may also return a list of strings if the window 5058system supports multiple selections. The first string will be 5059used as the pasted text, but the other will be placed in the kill 5060ring for easy access via `yank-pop'. 5061 5062Note that the function should return a string only if a program 5063other than Emacs has provided a string for pasting; if Emacs 5064provided the most recent string, the function should return nil. 5065If it is difficult to tell whether Emacs or some other program 5066provided the current string, it is probably good enough to return 5067nil if the string is equal (according to `string=') to the last 5068text Emacs provided.") 5069 5070 5071 5072;;;; The kill ring data structure. 5073 5074(defvar kill-ring nil 5075 "List of killed text sequences. 5076Since the kill ring is supposed to interact nicely with cut-and-paste 5077facilities offered by window systems, use of this variable should 5078interact nicely with `interprogram-cut-function' and 5079`interprogram-paste-function'. The functions `kill-new', 5080`kill-append', and `current-kill' are supposed to implement this 5081interaction; you may want to use them instead of manipulating the kill 5082ring directly.") 5083 5084(defcustom kill-ring-max 120 5085 "Maximum length of kill ring before oldest elements are thrown away." 5086 :type 'integer 5087 :group 'killing 5088 :version "29.1") 5089 5090(defvar kill-ring-yank-pointer nil 5091 "The tail of the kill ring whose car is the last thing yanked.") 5092 5093(defcustom save-interprogram-paste-before-kill nil 5094 "Whether to save existing clipboard text into kill ring before replacing it. 5095A non-nil value means the clipboard text is saved to the `kill-ring' 5096prior to any kill command. Such text can subsequently be retrieved 5097via \\[yank] \\[yank-pop]. This ensures that Emacs kill operations 5098do not irrevocably overwrite existing clipboard text. 5099 5100The value of this variable can also be a number, in which case the 5101clipboard data is only saved to the `kill-ring' if it's shorter 5102(in characters) than that number. Any other non-nil value will save 5103the clipboard data unconditionally." 5104 :type '(choice (const nil) 5105 number 5106 (other :tag "Always" t)) 5107 :group 'killing 5108 :version "23.2") 5109 5110(defcustom kill-do-not-save-duplicates nil 5111 "If non-nil, don't add a string to `kill-ring' if it duplicates the last one. 5112The comparison is done using `equal-including-properties'." 5113 :type 'boolean 5114 :group 'killing 5115 :version "23.2") 5116 5117(defcustom kill-transform-function nil 5118 "Function to call to transform a string before it's put on the kill ring. 5119The function is called with one parameter (the string that's to 5120be put on the kill ring). It should return a string or nil. If 5121the latter, the string is not put on the kill ring." 5122 :type '(choice (const :tag "No transform" nil) 5123 function) 5124 :group 'killing 5125 :version "28.1") 5126 5127(defun kill-new (string &optional replace) 5128 "Make STRING the latest kill in the kill ring. 5129Set `kill-ring-yank-pointer' to point to it. 5130If `interprogram-cut-function' is non-nil, apply it to STRING. 5131Optional second argument REPLACE non-nil means that STRING will replace 5132the front of the kill ring, rather than being added to the list. 5133 5134When `save-interprogram-paste-before-kill' and `interprogram-paste-function' 5135are non-nil, save the interprogram paste string(s) into `kill-ring' before 5136STRING. 5137 5138When the yank handler has a non-nil PARAM element, the original STRING 5139argument is not used by `insert-for-yank'. However, since Lisp code 5140may access and use elements from the kill ring directly, the STRING 5141argument should still be a \"useful\" string for such uses." 5142 ;; Allow the user to transform or ignore the string. 5143 (when (or (not kill-transform-function) 5144 (setq string (funcall kill-transform-function string))) 5145 (unless (and kill-do-not-save-duplicates 5146 ;; Due to text properties such as 'yank-handler that 5147 ;; can alter the contents to yank, comparison using 5148 ;; `equal' is unsafe. 5149 (equal-including-properties string (car kill-ring))) 5150 (if (fboundp 'menu-bar-update-yank-menu) 5151 (menu-bar-update-yank-menu string (and replace (car kill-ring))))) 5152 (when save-interprogram-paste-before-kill 5153 (let ((interprogram-paste (and interprogram-paste-function 5154 (funcall interprogram-paste-function)))) 5155 (when interprogram-paste 5156 (setq interprogram-paste 5157 (if (listp interprogram-paste) 5158 ;; Use `reverse' to avoid modifying external data. 5159 (reverse interprogram-paste) 5160 (list interprogram-paste))) 5161 (when (or (not (numberp save-interprogram-paste-before-kill)) 5162 (< (seq-reduce #'+ (mapcar #'length interprogram-paste) 0) 5163 save-interprogram-paste-before-kill)) 5164 (dolist (s interprogram-paste) 5165 (unless (and kill-do-not-save-duplicates 5166 (equal-including-properties s (car kill-ring))) 5167 (push s kill-ring))))))) 5168 (unless (and kill-do-not-save-duplicates 5169 (equal-including-properties string (car kill-ring))) 5170 (if (and replace kill-ring) 5171 (setcar kill-ring string) 5172 (let ((history-delete-duplicates nil)) 5173 (add-to-history 'kill-ring string kill-ring-max t)))) 5174 (setq kill-ring-yank-pointer kill-ring) 5175 (if interprogram-cut-function 5176 (funcall interprogram-cut-function string)))) 5177 5178;; It has been argued that this should work like `self-insert-command' 5179;; which merges insertions in `buffer-undo-list' in groups of 20 5180;; (hard-coded in `undo-auto-amalgamate'). 5181(defcustom kill-append-merge-undo nil 5182 "Amalgamate appending kills with the last kill for undo. 5183When non-nil, appending or prepending text to the last kill makes 5184\\[undo] restore both pieces of text simultaneously." 5185 :type 'boolean 5186 :group 'killing 5187 :version "25.1") 5188 5189(defun kill-append (string before-p) 5190 "Append STRING to the end of the latest kill in the kill ring. 5191If BEFORE-P is non-nil, prepend STRING to the kill instead. 5192If `interprogram-cut-function' is non-nil, call it with the 5193resulting kill. 5194If `kill-append-merge-undo' is non-nil, remove the last undo 5195boundary in the current buffer." 5196 (let ((cur (car kill-ring))) 5197 (kill-new (if before-p (concat string cur) (concat cur string)) 5198 (or (string= cur "") 5199 (null (get-text-property 0 'yank-handler cur))))) 5200 (when (and kill-append-merge-undo (not buffer-read-only)) 5201 (let ((prev buffer-undo-list) 5202 (next (cdr buffer-undo-list))) 5203 ;; Find the next undo boundary. 5204 (while (car next) 5205 (pop next) 5206 (pop prev)) 5207 ;; Remove this undo boundary. 5208 (when prev 5209 (setcdr prev (cdr next)))))) 5210 5211(defcustom yank-pop-change-selection nil 5212 "Whether rotating the kill ring changes the window system selection. 5213If non-nil, whenever the kill ring is rotated (usually via the 5214`yank-pop' command), Emacs also calls `interprogram-cut-function' 5215to copy the new kill to the window system selection." 5216 :type 'boolean 5217 :group 'killing 5218 :version "23.1") 5219 5220(defun current-kill (n &optional do-not-move) 5221 "Rotate the yanking point by N places, and then return that kill. 5222If N is zero and `interprogram-paste-function' is set to a 5223function that returns a string or a list of strings, and if that 5224function doesn't return nil, then that string (or list) is added 5225to the front of the kill ring and the string (or first string in 5226the list) is returned as the latest kill. 5227 5228If N is not zero, and if `yank-pop-change-selection' is 5229non-nil, use `interprogram-cut-function' to transfer the 5230kill at the new yank point into the window system selection. 5231 5232If optional arg DO-NOT-MOVE is non-nil, then don't actually 5233move the yanking point; just return the Nth kill forward." 5234 5235 (let ((interprogram-paste (and (= n 0) 5236 interprogram-paste-function 5237 (funcall interprogram-paste-function)))) 5238 (if interprogram-paste 5239 (progn 5240 ;; Disable the interprogram cut function when we add the new 5241 ;; text to the kill ring, so Emacs doesn't try to own the 5242 ;; selection, with identical text. 5243 ;; Also disable the interprogram paste function, so that 5244 ;; `kill-new' doesn't call it repeatedly. 5245 (let ((interprogram-cut-function nil) 5246 (interprogram-paste-function nil)) 5247 (if (listp interprogram-paste) 5248 ;; Use `reverse' to avoid modifying external data. 5249 (mapc #'kill-new (reverse interprogram-paste)) 5250 (kill-new interprogram-paste))) 5251 (car kill-ring)) 5252 (or kill-ring (error "Kill ring is empty")) 5253 (let ((ARGth-kill-element 5254 (nthcdr (mod (- n (length kill-ring-yank-pointer)) 5255 (length kill-ring)) 5256 kill-ring))) 5257 (unless do-not-move 5258 (setq kill-ring-yank-pointer ARGth-kill-element) 5259 (when (and yank-pop-change-selection 5260 (> n 0) 5261 interprogram-cut-function) 5262 (funcall interprogram-cut-function (car ARGth-kill-element)))) 5263 (car ARGth-kill-element))))) 5264 5265 5266 5267;;;; Commands for manipulating the kill ring. 5268 5269(defcustom kill-read-only-ok nil 5270 "Non-nil means don't signal an error for killing read-only text." 5271 :type 'boolean 5272 :group 'killing) 5273 5274(defun kill-region (beg end &optional region) 5275 "Kill (\"cut\") text between point and mark. 5276This deletes the text from the buffer and saves it in the kill ring. 5277The command \\[yank] can retrieve it from there. 5278\(If you want to save the region without killing it, use \\[kill-ring-save].) 5279 5280If you want to append the killed region to the last killed text, 5281use \\[append-next-kill] before \\[kill-region]. 5282 5283Any command that calls this function is a \"kill command\". 5284If the previous command was also a kill command, 5285the text killed this time appends to the text killed last time 5286to make one entry in the kill ring. 5287 5288The killed text is filtered by `filter-buffer-substring' before it is 5289saved in the kill ring, so the actual saved text might be different 5290from what was killed. 5291 5292If the buffer is read-only, Emacs will beep and refrain from deleting 5293the text, but put the text in the kill ring anyway. This means that 5294you can use the killing commands to copy text from a read-only buffer. 5295 5296Lisp programs should use this function for killing text. 5297 (To delete text, use `delete-region'.) 5298Supply two arguments, character positions BEG and END indicating the 5299 stretch of text to be killed. If the optional argument REGION is 5300 non-nil, the function ignores BEG and END, and kills the current 5301 region instead. Interactively, REGION is always non-nil, and so 5302 this command always kills the current region." 5303 ;; Pass mark first, then point, because the order matters when 5304 ;; calling `kill-append'. 5305 (interactive (progn 5306 (let ((beg (mark)) 5307 (end (point))) 5308 (unless (and beg end) 5309 (user-error "The mark is not set now, so there is no region")) 5310 (list beg end 'region)))) 5311 (condition-case nil 5312 (let ((string (if region 5313 (funcall region-extract-function 'delete) 5314 (filter-buffer-substring beg end 'delete)))) 5315 (when string ;STRING is nil if BEG = END 5316 ;; Add that string to the kill ring, one way or another. 5317 (if (eq last-command 'kill-region) 5318 (kill-append string (< end beg)) 5319 (kill-new string))) 5320 (when (or string (eq last-command 'kill-region)) 5321 (setq this-command 'kill-region)) 5322 (setq deactivate-mark t) 5323 nil) 5324 ((buffer-read-only text-read-only) 5325 ;; The code above failed because the buffer, or some of the characters 5326 ;; in the region, are read-only. 5327 ;; We should beep, in case the user just isn't aware of this. 5328 ;; However, there's no harm in putting 5329 ;; the region's text in the kill ring, anyway. 5330 (copy-region-as-kill beg end region) 5331 ;; Set this-command now, so it will be set even if we get an error. 5332 (setq this-command 'kill-region) 5333 ;; This should barf, if appropriate, and give us the correct error. 5334 (if kill-read-only-ok 5335 (progn (message "Read only text copied to kill ring") nil) 5336 ;; Signal an error if the buffer is read-only. 5337 (barf-if-buffer-read-only) 5338 ;; If the buffer isn't read-only, the text is. 5339 (signal 'text-read-only (list (current-buffer))))))) 5340 5341;; copy-region-as-kill no longer sets this-command, because it's confusing 5342;; to get two copies of the text when the user accidentally types M-w and 5343;; then corrects it with the intended C-w. 5344(defun copy-region-as-kill (beg end &optional region) 5345 "Save the region as if killed, but don't kill it. 5346In Transient Mark mode, deactivate the mark. 5347If `interprogram-cut-function' is non-nil, also save the text for a window 5348system cut and paste. 5349 5350The copied text is filtered by `filter-buffer-substring' before it is 5351saved in the kill ring, so the actual saved text might be different 5352from what was in the buffer. 5353 5354When called from Lisp, save in the kill ring the stretch of text 5355between BEG and END, unless the optional argument REGION is 5356non-nil, in which case ignore BEG and END, and save the current 5357region instead. 5358 5359This command's old key binding has been given to `kill-ring-save'." 5360 ;; Pass mark first, then point, because the order matters when 5361 ;; calling `kill-append'. 5362 (interactive (list (mark) (point) 'region)) 5363 (let ((str (if region 5364 (funcall region-extract-function nil) 5365 (filter-buffer-substring beg end)))) 5366 (if (eq last-command 'kill-region) 5367 (kill-append str (< end beg)) 5368 (kill-new str))) 5369 (setq deactivate-mark t) 5370 nil) 5371 5372(defun kill-ring-save (beg end &optional region) 5373 "Save the region as if killed, but don't kill it. 5374In Transient Mark mode, deactivate the mark. 5375If `interprogram-cut-function' is non-nil, also save the text for a window 5376system cut and paste. 5377 5378If you want to append the killed region to the last killed text, 5379use \\[append-next-kill] before \\[kill-ring-save]. 5380 5381The copied text is filtered by `filter-buffer-substring' before it is 5382saved in the kill ring, so the actual saved text might be different 5383from what was in the buffer. 5384 5385When called from Lisp, save in the kill ring the stretch of text 5386between BEG and END, unless the optional argument REGION is 5387non-nil, in which case ignore BEG and END, and save the current 5388region instead. 5389 5390This command is similar to `copy-region-as-kill', except that it gives 5391visual feedback indicating the extent of the region being copied." 5392 ;; Pass mark first, then point, because the order matters when 5393 ;; calling `kill-append'. 5394 (interactive (list (mark) (point) 'region)) 5395 (copy-region-as-kill beg end region) 5396 ;; This use of called-interactively-p is correct because the code it 5397 ;; controls just gives the user visual feedback. 5398 (if (called-interactively-p 'interactive) 5399 (indicate-copied-region))) 5400 5401(defcustom copy-region-blink-delay 1 5402 "Time in seconds to delay after showing the other end of the region. 5403It's used by the command `kill-ring-save' and the function 5404`indicate-copied-region' to blink the cursor between point and mark. 5405The value 0 disables blinking." 5406 :type 'number 5407 :group 'killing 5408 :version "28.1") 5409 5410(defun indicate-copied-region (&optional message-len) 5411 "Indicate that the region text has been copied interactively. 5412If the mark is visible in the selected window, blink the cursor between 5413point and mark if there is currently no active region highlighting. 5414The option `copy-region-blink-delay' can disable blinking. 5415 5416If the mark lies outside the selected window, display an 5417informative message containing a sample of the copied text. The 5418optional argument MESSAGE-LEN, if non-nil, specifies the length 5419of this sample text; it defaults to 40." 5420 (let ((mark (mark t)) 5421 (point (point)) 5422 ;; Inhibit quitting so we can make a quit here 5423 ;; look like a C-g typed as a command. 5424 (inhibit-quit t)) 5425 (if (pos-visible-in-window-p mark (selected-window)) 5426 ;; Swap point-and-mark quickly so as to show the region that 5427 ;; was selected. Don't do it if the region is highlighted. 5428 (when (and (numberp copy-region-blink-delay) 5429 (> copy-region-blink-delay 0) 5430 (or (not (region-active-p)) 5431 (not (face-background 'region nil t)))) 5432 ;; Swap point and mark. 5433 (set-marker (mark-marker) (point) (current-buffer)) 5434 (goto-char mark) 5435 (sit-for copy-region-blink-delay) 5436 ;; Swap back. 5437 (set-marker (mark-marker) mark (current-buffer)) 5438 (goto-char point) 5439 ;; If user quit, deactivate the mark 5440 ;; as C-g would as a command. 5441 (and quit-flag (region-active-p) 5442 (deactivate-mark))) 5443 (let ((len (min (abs (- mark point)) 5444 (or message-len 40)))) 5445 (if (< point mark) 5446 ;; Don't say "killed" or "saved"; that is misleading. 5447 (message "Copied text until \"%s\"" 5448 ;; Don't show newlines literally 5449 (query-replace-descr 5450 (buffer-substring-no-properties (- mark len) mark))) 5451 (message "Copied text from \"%s\"" 5452 (query-replace-descr 5453 (buffer-substring-no-properties mark (+ mark len))))))))) 5454 5455(defun append-next-kill (&optional interactive) 5456 "Cause following command, if it kills, to add to previous kill. 5457If the next command kills forward from point, the kill is 5458appended to the previous killed text. If the command kills 5459backward, the kill is prepended. Kill commands that act on the 5460region, such as `kill-region', are regarded as killing forward if 5461point is after mark, and killing backward if point is before 5462mark. 5463 5464If the next command is not a kill command, `append-next-kill' has 5465no effect. 5466 5467The argument is used for internal purposes; do not supply one." 5468 (interactive "p") 5469 ;; We don't use (interactive-p), since that breaks kbd macros. 5470 (if interactive 5471 (progn 5472 (setq this-command 'kill-region) 5473 (message "If the next command is a kill, it will append")) 5474 (setq last-command 'kill-region))) 5475 5476(defvar bidi-directional-controls-chars "\x202a-\x202e\x2066-\x2069" 5477 "Character set that matches bidirectional formatting control characters.") 5478 5479(defvar bidi-directional-non-controls-chars "^\x202a-\x202e\x2066-\x2069" 5480 "Character set that matches any character except bidirectional controls.") 5481 5482(defun squeeze-bidi-context-1 (from to category replacement) 5483 "A subroutine of `squeeze-bidi-context'. 5484FROM and TO should be markers, CATEGORY and REPLACEMENT should be strings." 5485 (let ((pt (copy-marker from)) 5486 (limit (copy-marker to)) 5487 (old-pt 0) 5488 lim1) 5489 (setq lim1 limit) 5490 (goto-char pt) 5491 (while (< pt limit) 5492 (if (> pt old-pt) 5493 (move-marker lim1 5494 (save-excursion 5495 ;; L and R categories include embedding and 5496 ;; override controls, but we don't want to 5497 ;; replace them, because that might change 5498 ;; the visual order. Likewise with PDF and 5499 ;; isolate controls. 5500 (+ pt (skip-chars-forward 5501 bidi-directional-non-controls-chars 5502 limit))))) 5503 ;; Replace any run of non-RTL characters by a single LRM. 5504 (if (null (re-search-forward category lim1 t)) 5505 ;; No more characters of CATEGORY, we are done. 5506 (setq pt limit) 5507 (replace-match replacement nil t) 5508 (move-marker pt (point))) 5509 (setq old-pt pt) 5510 ;; Skip directional controls, if any. 5511 (move-marker 5512 pt (+ pt (skip-chars-forward bidi-directional-controls-chars limit)))))) 5513 5514(defun squeeze-bidi-context (from to) 5515 "Replace characters between FROM and TO while keeping bidi context. 5516 5517This function replaces the region of text with as few characters 5518as possible, while preserving the effect that region will have on 5519bidirectional display before and after the region." 5520 (let ((start (set-marker (make-marker) 5521 (if (> from 0) from (+ (point-max) from)))) 5522 (end (set-marker (make-marker) to)) 5523 ;; This is for when they copy text with read-only text 5524 ;; properties. 5525 (inhibit-read-only t)) 5526 (if (null (marker-position end)) 5527 (setq end (point-max-marker))) 5528 ;; Replace each run of non-RTL characters with a single LRM. 5529 (squeeze-bidi-context-1 start end "\\CR+" "\x200e") 5530 ;; Replace each run of non-LTR characters with a single RLM. Note 5531 ;; that the \cR category includes both the Arabic Letter (AL) and 5532 ;; R characters; here we ignore the distinction between them, 5533 ;; because that distinction affects only Arabic Number (AN) 5534 ;; characters, which are weak and don't affect the reordering. 5535 (squeeze-bidi-context-1 start end "\\CL+" "\x200f"))) 5536 5537(defun line-substring-with-bidi-context (start end &optional no-properties) 5538 "Return buffer text between START and END with its bidi context. 5539 5540START and END are assumed to belong to the same physical line 5541of buffer text. This function prepends and appends to the text 5542between START and END bidi control characters that preserve the 5543visual order of that text when it is inserted at some other place." 5544 (if (or (< start (point-min)) 5545 (> end (point-max))) 5546 (signal 'args-out-of-range (list (current-buffer) start end))) 5547 (let ((buf (current-buffer)) 5548 substr para-dir from to) 5549 (save-excursion 5550 (goto-char start) 5551 (setq para-dir (current-bidi-paragraph-direction)) 5552 (setq from (line-beginning-position) 5553 to (line-end-position)) 5554 (goto-char from) 5555 ;; If we don't have any mixed directional characters in the 5556 ;; entire line, we can just copy the substring without adding 5557 ;; any context. 5558 (if (or (looking-at-p "\\CR*$") 5559 (looking-at-p "\\CL*$")) 5560 (setq substr (if no-properties 5561 (buffer-substring-no-properties start end) 5562 (buffer-substring start end))) 5563 (setq substr 5564 (with-temp-buffer 5565 (if no-properties 5566 (insert-buffer-substring-no-properties buf from to) 5567 (insert-buffer-substring buf from to)) 5568 (squeeze-bidi-context 1 (1+ (- start from))) 5569 (squeeze-bidi-context (- end to) nil) 5570 (buffer-substring 1 (point-max))))) 5571 5572 ;; Wrap the string in LRI/RLI..PDI pair to achieve 2 effects: 5573 ;; (1) force the string to have the same base embedding 5574 ;; direction as the paragraph direction at the source, no matter 5575 ;; what is the paragraph direction at destination; and (2) avoid 5576 ;; affecting the visual order of the surrounding text at 5577 ;; destination if there are characters of different 5578 ;; directionality there. 5579 (concat (if (eq para-dir 'left-to-right) "\x2066" "\x2067") 5580 substr "\x2069")))) 5581 5582(defun buffer-substring-with-bidi-context (start end &optional no-properties) 5583 "Return portion of current buffer between START and END with bidi context. 5584 5585This function works similar to `buffer-substring', but it prepends and 5586appends to the text bidi directional control characters necessary to 5587preserve the visual appearance of the text if it is inserted at another 5588place. This is useful when the buffer substring includes bidirectional 5589text and control characters that cause non-trivial reordering on display. 5590If copied verbatim, such text can have a very different visual appearance, 5591and can also change the visual appearance of the surrounding text at the 5592destination of the copy. 5593 5594Optional argument NO-PROPERTIES, if non-nil, means copy the text without 5595the text properties." 5596 (let (line-end substr) 5597 (if (or (< start (point-min)) 5598 (> end (point-max))) 5599 (signal 'args-out-of-range (list (current-buffer) start end))) 5600 (save-excursion 5601 (goto-char start) 5602 (setq line-end (min end (line-end-position))) 5603 (while (< start end) 5604 (setq substr 5605 (concat substr 5606 (if substr "\n" "") 5607 (line-substring-with-bidi-context start line-end 5608 no-properties))) 5609 (forward-line 1) 5610 (setq start (point)) 5611 (setq line-end (min end (line-end-position)))) 5612 substr))) 5613 5614;; Yanking. 5615 5616(defcustom yank-handled-properties 5617 '((font-lock-face . yank-handle-font-lock-face-property) 5618 (category . yank-handle-category-property)) 5619 "List of special text property handling conditions for yanking. 5620Each element should have the form (PROP . FUN), where PROP is a 5621property symbol and FUN is a function. When the `yank' command 5622inserts text into the buffer, it scans the inserted text for 5623stretches of text that have `eq' values of the text property 5624PROP; for each such stretch of text, FUN is called with three 5625arguments: the property's value in that text, and the start and 5626end positions of the text. 5627 5628This is done prior to removing the properties specified by 5629`yank-excluded-properties'." 5630 :group 'killing 5631 :type '(repeat (cons (symbol :tag "property symbol") 5632 function)) 5633 :version "24.3") 5634 5635;; This is actually used in subr.el but defcustom does not work there. 5636(defcustom yank-excluded-properties 5637 '(category field follow-link fontified font-lock-face help-echo 5638 intangible invisible keymap local-map mouse-face read-only 5639 yank-handler) 5640 "Text properties to discard when yanking. 5641The value should be a list of text properties to discard or t, 5642which means to discard all text properties. 5643 5644See also `yank-handled-properties'." 5645 :type '(choice (const :tag "All" t) (repeat symbol)) 5646 :group 'killing 5647 :version "24.3") 5648 5649(defvar yank-window-start nil) 5650(defvar yank-undo-function nil 5651 "If non-nil, function used by `yank-pop' to delete last stretch of yanked text. 5652Function is called with two parameters, START and END corresponding to 5653the value of the mark and point; it is guaranteed that START <= END. 5654Normally set from the UNDO element of a yank-handler; see `insert-for-yank'.") 5655 5656(defun yank-pop (&optional arg) 5657 "Replace just-yanked stretch of killed text with a different stretch. 5658The main use of this command is immediately after a `yank' or a 5659`yank-pop'. At such a time, the region contains a stretch of 5660reinserted (\"pasted\") previously-killed text. `yank-pop' deletes 5661that text and inserts in its place a different stretch of killed text 5662by traversing the value of the `kill-ring' variable and selecting 5663another kill from there. 5664 5665With no argument, the previous kill is inserted. 5666With argument N, insert the Nth previous kill. 5667If N is negative, it means to use a more recent kill. 5668 5669The sequence of kills wraps around, so if you keep invoking this command 5670time after time, and pass the oldest kill, you get the newest one. 5671 5672You can also invoke this command after a command other than `yank' 5673or `yank-pop'. This is the same as invoking `yank-from-kill-ring', 5674including the effect of the prefix argument; see there for the details. 5675 5676This command honors the `yank-handled-properties' and 5677`yank-excluded-properties' variables, and the `yank-handler' text 5678property, in the way that `yank' does." 5679 (interactive "p") 5680 (if (not (eq last-command 'yank)) 5681 (yank-from-kill-ring (read-from-kill-ring "Yank from kill-ring: ") 5682 current-prefix-arg) 5683 (setq this-command 'yank) 5684 (unless arg (setq arg 1)) 5685 (let ((inhibit-read-only t) 5686 (before (< (point) (mark t)))) 5687 (if before 5688 (funcall (or yank-undo-function 'delete-region) (point) (mark t)) 5689 (funcall (or yank-undo-function 'delete-region) (mark t) (point))) 5690 (setq yank-undo-function nil) 5691 (set-marker (mark-marker) (point) (current-buffer)) 5692 (insert-for-yank (current-kill arg)) 5693 ;; Set the window start back where it was in the yank command, 5694 ;; if possible. 5695 (set-window-start (selected-window) yank-window-start t) 5696 (if before 5697 ;; This is like exchange-point-and-mark, but doesn't activate the mark. 5698 ;; It is cleaner to avoid activation, even though the command 5699 ;; loop would deactivate the mark because we inserted text. 5700 (goto-char (prog1 (mark t) 5701 (set-marker (mark-marker) (point) (current-buffer)))))) 5702 nil)) 5703 5704(defun yank (&optional arg) 5705 "Reinsert (\"paste\") the last stretch of killed text. 5706More precisely, reinsert the most recent kill, which is the stretch of 5707text most recently killed OR yanked, as returned by `current-kill' (which 5708see). Put point at the end, and set mark at the beginning without 5709activating it. With just \\[universal-argument] as argument, put point 5710at beginning, and mark at end. 5711With argument N, reinsert the Nth most recent kill. 5712 5713This command honors the `yank-handled-properties' and 5714`yank-excluded-properties' variables, and the `yank-handler' text 5715property, as described below. 5716 5717Properties listed in `yank-handled-properties' are processed, 5718then those listed in `yank-excluded-properties' are discarded. 5719 5720If STRING has a non-nil `yank-handler' property anywhere, the 5721normal insert behavior is altered, and instead, for each contiguous 5722segment of STRING that has a given value of the `yank-handler' 5723property, that value is used as follows: 5724 5725The value of a `yank-handler' property must be a list of one to four 5726elements, of the form (FUNCTION PARAM NOEXCLUDE UNDO). 5727FUNCTION, if non-nil, should be a function of one argument (the 5728 object to insert); FUNCTION is called instead of `insert'. 5729PARAM, if present and non-nil, is passed to FUNCTION (to be handled 5730 in whatever way is appropriate; e.g. if FUNCTION is `yank-rectangle', 5731 PARAM may be a list of strings to insert as a rectangle). If PARAM 5732 is nil, then the current segment of STRING is used. 5733If NOEXCLUDE is present and non-nil, the normal removal of 5734 `yank-excluded-properties' is not performed; instead FUNCTION is 5735 responsible for the removal. This may be necessary if FUNCTION 5736 adjusts point before or after inserting the object. 5737UNDO, if present and non-nil, should be a function to be called 5738 by `yank-pop' to undo the insertion of the current PARAM. It is 5739 given two arguments, the start and end of the region. FUNCTION 5740 may set `yank-undo-function' to override UNDO. 5741 5742See also the command `yank-pop' (\\[yank-pop])." 5743 (interactive "*P") 5744 (setq yank-window-start (window-start)) 5745 ;; If we don't get all the way thru, make last-command indicate that 5746 ;; for the following command. 5747 (setq this-command t) 5748 (push-mark) 5749 (insert-for-yank (current-kill (cond 5750 ((listp arg) 0) 5751 ((eq arg '-) -2) 5752 (t (1- arg))))) 5753 (if (consp arg) 5754 ;; This is like exchange-point-and-mark, but doesn't activate the mark. 5755 ;; It is cleaner to avoid activation, even though the command 5756 ;; loop would deactivate the mark because we inserted text. 5757 (goto-char (prog1 (mark t) 5758 (set-marker (mark-marker) (point) (current-buffer))))) 5759 ;; If we do get all the way thru, make this-command indicate that. 5760 (if (eq this-command t) 5761 (setq this-command 'yank)) 5762 nil) 5763 5764(defun rotate-yank-pointer (arg) 5765 "Rotate the yanking point in the kill ring. 5766With ARG, rotate that many kills forward (or backward, if negative)." 5767 (interactive "p") 5768 (current-kill arg)) 5769 5770(defvar read-from-kill-ring-history) 5771(defun read-from-kill-ring (prompt) 5772 "Read a `kill-ring' entry using completion and minibuffer history. 5773PROMPT is a string to prompt with." 5774 ;; `current-kill' updates `kill-ring' with a possible interprogram-paste 5775 (current-kill 0) 5776 (let* ((history-add-new-input nil) 5777 (history-pos (when yank-from-kill-ring-rotate 5778 (- (length kill-ring) 5779 (length kill-ring-yank-pointer)))) 5780 (ellipsis (if (char-displayable-p ?…) "…" "...")) 5781 ;; Remove keymaps from text properties of copied string, 5782 ;; because typing RET in the minibuffer might call 5783 ;; an irrelevant command from the map of copied string. 5784 (read-from-kill-ring-history 5785 (mapcar (lambda (s) 5786 (remove-list-of-text-properties 5787 0 (length s) 5788 '( 5789 keymap local-map action mouse-action 5790 button category help-args) 5791 s) 5792 s) 5793 kill-ring)) 5794 (completions 5795 (mapcar (lambda (s) 5796 (let* ((s (query-replace-descr s)) 5797 (b 0) 5798 (limit (frame-text-cols))) 5799 ;; Add ellipsis on leading whitespace 5800 (when (string-match "\\`[[:space:]]+" s) 5801 (setq b (match-end 0)) 5802 (add-text-properties 0 b `(display ,ellipsis) s)) 5803 ;; Add ellipsis at the end of a long string 5804 (when (> (length s) (+ limit b)) 5805 (add-text-properties 5806 (min (+ limit b) (length s)) (length s) 5807 `(display ,ellipsis) s)) 5808 s)) 5809 read-from-kill-ring-history))) 5810 (minibuffer-with-setup-hook 5811 (lambda () 5812 ;; Allow ‘SPC’ to be self-inserting 5813 (use-local-map 5814 (let ((map (make-sparse-keymap))) 5815 (set-keymap-parent map (current-local-map)) 5816 (define-key map " " nil) 5817 (define-key map "?" nil) 5818 map))) 5819 (completing-read 5820 prompt 5821 (lambda (string pred action) 5822 (if (eq action 'metadata) 5823 ;; Keep sorted by recency 5824 '(metadata (display-sort-function . identity)) 5825 (complete-with-action action completions string pred))) 5826 nil nil nil 5827 (if history-pos 5828 (cons 'read-from-kill-ring-history 5829 (if (zerop history-pos) history-pos (1+ history-pos))) 5830 'read-from-kill-ring-history))))) 5831 5832(defcustom yank-from-kill-ring-rotate t 5833 "Whether using `yank-from-kill-ring' should rotate `kill-ring-yank-pointer'. 5834If non-nil, the kill ring is rotated after selecting previously killed text." 5835 :type 'boolean 5836 :group 'killing 5837 :version "28.1") 5838 5839(defun yank-from-kill-ring (string &optional arg) 5840 "Select a stretch of previously killed text and insert (\"paste\") it. 5841This command allows to choose one of the stretches of text killed 5842or yanked by previous commands, which are recorded in `kill-ring', 5843and reinsert the chosen kill at point. 5844 5845This command prompts for a previously-killed text in the minibuffer. 5846Use the minibuffer history and search commands, or the minibuffer 5847completion commands, to select a previously-killed text. In 5848particular, typing \\<minibuffer-local-completion-map>\\[minibuffer-complete] at the prompt will pop up a buffer showing 5849all the previously-killed stretches of text from which you can 5850choose the one you want to reinsert. 5851Once you select the text you want to reinsert, type \\<minibuffer-local-map>\\[exit-minibuffer] to actually 5852insert it and exit the minibuffer. 5853You can also edit the selected text in the minibuffer before 5854inserting it. 5855 5856With \\[universal-argument] as argument, this command puts point at 5857beginning of the inserted text and mark at the end, like `yank' does. 5858 5859When called from Lisp, insert STRING like `insert-for-yank' does." 5860 (interactive (list (read-from-kill-ring "Yank from kill-ring: ") 5861 current-prefix-arg)) 5862 (setq yank-window-start (window-start)) 5863 (push-mark) 5864 (insert-for-yank string) 5865 (when yank-from-kill-ring-rotate 5866 (let ((pos (seq-position kill-ring string))) 5867 (if pos 5868 (setq kill-ring-yank-pointer (nthcdr pos kill-ring)) 5869 (kill-new string)))) 5870 (if (consp arg) 5871 ;; Swap point and mark like in `yank' and `yank-pop'. 5872 (goto-char (prog1 (mark t) 5873 (set-marker (mark-marker) (point) (current-buffer)))))) 5874 5875 5876;; Some kill commands. 5877 5878;; Internal subroutine of delete-char 5879(defun kill-forward-chars (arg) 5880 (if (listp arg) (setq arg (car arg))) 5881 (if (eq arg '-) (setq arg -1)) 5882 (kill-region (point) (+ (point) arg))) 5883 5884;; Internal subroutine of backward-delete-char 5885(defun kill-backward-chars (arg) 5886 (if (listp arg) (setq arg (car arg))) 5887 (if (eq arg '-) (setq arg -1)) 5888 (kill-region (point) (- (point) arg))) 5889 5890(defcustom backward-delete-char-untabify-method 'untabify 5891 "The method for untabifying when deleting backward. 5892Can be `untabify' -- turn a tab to many spaces, then delete one space; 5893 `hungry' -- delete all whitespace, both tabs and spaces; 5894 `all' -- delete all whitespace, including tabs, spaces and newlines; 5895 nil -- just delete one character." 5896 :type '(choice (const untabify) (const hungry) (const all) (const nil)) 5897 :version "20.3" 5898 :group 'killing) 5899 5900(defun backward-delete-char-untabify (arg &optional killp) 5901 "Delete characters backward, changing tabs into spaces. 5902The exact behavior depends on `backward-delete-char-untabify-method'. 5903 5904Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil. 5905 5906If Transient Mark mode is enabled, the mark is active, and ARG is 1, 5907delete the text in the region and deactivate the mark instead. 5908To disable this, set option ‘delete-active-region’ to nil. 5909 5910Interactively, ARG is the prefix arg (default 1) 5911and KILLP is t if a prefix arg was specified." 5912 (interactive "*p\nP") 5913 (when (eq backward-delete-char-untabify-method 'untabify) 5914 (let ((count arg)) 5915 (save-excursion 5916 (while (and (> count 0) (not (bobp))) 5917 (if (= (preceding-char) ?\t) 5918 (let ((col (current-column))) 5919 (forward-char -1) 5920 (setq col (- col (current-column))) 5921 (insert-char ?\s col) 5922 (delete-char 1))) 5923 (forward-char -1) 5924 (setq count (1- count)))))) 5925 (let* ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t") 5926 ((eq backward-delete-char-untabify-method 'all) 5927 " \t\n\r"))) 5928 (n (if skip 5929 (let* ((oldpt (point)) 5930 (wh (- oldpt (save-excursion 5931 (skip-chars-backward skip) 5932 (constrain-to-field nil oldpt))))) 5933 (+ arg (if (zerop wh) 0 (1- wh)))) 5934 arg))) 5935 ;; Avoid warning about delete-backward-char 5936 (with-no-warnings (delete-backward-char n killp)))) 5937 5938(defun zap-to-char (arg char) 5939 "Kill up to and including ARGth occurrence of CHAR. 5940Case is ignored if `case-fold-search' is non-nil in the current buffer. 5941Goes backward if ARG is negative; error if CHAR not found. 5942See also `zap-up-to-char'." 5943 (interactive (list (prefix-numeric-value current-prefix-arg) 5944 (read-char-from-minibuffer "Zap to char: " 5945 nil 'read-char-history))) 5946 ;; Avoid "obsolete" warnings for translation-table-for-input. 5947 (with-no-warnings 5948 (if (char-table-p translation-table-for-input) 5949 (setq char (or (aref translation-table-for-input char) char)))) 5950 (kill-region (point) (progn 5951 (search-forward (char-to-string char) nil nil arg) 5952 (point)))) 5953 5954;; kill-line and its subroutines. 5955 5956(defcustom kill-whole-line nil 5957 "If non-nil, `kill-line' with no arg at start of line kills the whole line. 5958This variable also affects `kill-visual-line' in the same way as 5959it does `kill-line'." 5960 :type 'boolean 5961 :group 'killing) 5962 5963(defun kill-line (&optional arg) 5964 "Kill the rest of the current line; if no nonblanks there, kill thru newline. 5965With prefix argument ARG, kill that many lines from point. 5966Negative arguments kill lines backward. 5967With zero argument, kills the text before point on the current line. 5968 5969When calling from a program, nil means \"no arg\", 5970a number counts as a prefix arg. 5971 5972To kill a whole line, when point is not at the beginning, type \ 5973\\[move-beginning-of-line] \\[kill-line] \\[kill-line]. 5974 5975If `show-trailing-whitespace' is non-nil, this command will just 5976kill the rest of the current line, even if there are no nonblanks 5977there. 5978 5979If option `kill-whole-line' is non-nil, then this command kills the whole line 5980including its terminating newline, when used at the beginning of a line 5981with no argument. As a consequence, you can always kill a whole line 5982by typing \\[move-beginning-of-line] \\[kill-line]. 5983 5984If you want to append the killed line to the last killed text, 5985use \\[append-next-kill] before \\[kill-line]. 5986 5987If the buffer is read-only, Emacs will beep and refrain from deleting 5988the line, but put the line in the kill ring anyway. This means that 5989you can use this command to copy text from a read-only buffer. 5990\(If the variable `kill-read-only-ok' is non-nil, then this won't 5991even beep.)" 5992 (interactive "P") 5993 (kill-region (point) 5994 ;; It is better to move point to the other end of the kill 5995 ;; before killing. That way, in a read-only buffer, point 5996 ;; moves across the text that is copied to the kill ring. 5997 ;; The choice has no effect on undo now that undo records 5998 ;; the value of point from before the command was run. 5999 (progn 6000 (if arg 6001 (forward-visible-line (prefix-numeric-value arg)) 6002 (if (eobp) 6003 (signal 'end-of-buffer nil)) 6004 (let ((end 6005 (save-excursion 6006 (end-of-visible-line) (point)))) 6007 (if (or (save-excursion 6008 ;; If trailing whitespace is visible, 6009 ;; don't treat it as nothing. 6010 (unless show-trailing-whitespace 6011 (skip-chars-forward " \t" end)) 6012 (= (point) end)) 6013 (and kill-whole-line (bolp))) 6014 (forward-visible-line 1) 6015 (goto-char end)))) 6016 (point)))) 6017 6018(defun kill-whole-line (&optional arg) 6019 "Kill current line. 6020With prefix ARG, kill that many lines starting from the current line. 6021If ARG is negative, kill backward. Also kill the preceding newline. 6022\(This is meant to make \\[repeat] work well with negative arguments.) 6023If ARG is zero, kill current line but exclude the trailing newline." 6024 (interactive "p") 6025 (or arg (setq arg 1)) 6026 (if (and (> arg 0) (eobp) (save-excursion (forward-visible-line 0) (eobp))) 6027 (signal 'end-of-buffer nil)) 6028 (if (and (< arg 0) (bobp) (save-excursion (end-of-visible-line) (bobp))) 6029 (signal 'beginning-of-buffer nil)) 6030 (unless (eq last-command 'kill-region) 6031 (kill-new "") 6032 (setq last-command 'kill-region)) 6033 (cond ((zerop arg) 6034 ;; We need to kill in two steps, because the previous command 6035 ;; could have been a kill command, in which case the text 6036 ;; before point needs to be prepended to the current kill 6037 ;; ring entry and the text after point appended. Also, we 6038 ;; need to use save-excursion to avoid copying the same text 6039 ;; twice to the kill ring in read-only buffers. 6040 (save-excursion 6041 (kill-region (point) (progn (forward-visible-line 0) (point)))) 6042 (kill-region (point) (progn (end-of-visible-line) (point)))) 6043 ((< arg 0) 6044 (save-excursion 6045 (kill-region (point) (progn (end-of-visible-line) (point)))) 6046 (kill-region (point) 6047 (progn (forward-visible-line (1+ arg)) 6048 (unless (bobp) (backward-char)) 6049 (point)))) 6050 (t 6051 (save-excursion 6052 (kill-region (point) (progn (forward-visible-line 0) (point)))) 6053 (kill-region (point) 6054 (progn (forward-visible-line arg) (point)))))) 6055 6056(defun forward-visible-line (arg) 6057 "Move forward by ARG lines, ignoring currently invisible newlines only. 6058If ARG is negative, move backward -ARG lines. 6059If ARG is zero, move to the beginning of the current line." 6060 (condition-case nil 6061 (if (> arg 0) 6062 (progn 6063 (while (> arg 0) 6064 (or (zerop (forward-line 1)) 6065 (signal 'end-of-buffer nil)) 6066 ;; If the newline we just skipped is invisible, 6067 ;; don't count it. 6068 (if (invisible-p (1- (point))) 6069 (setq arg (1+ arg))) 6070 (setq arg (1- arg))) 6071 ;; If invisible text follows, and it is a number of complete lines, 6072 ;; skip it. 6073 (let ((opoint (point))) 6074 (while (and (not (eobp)) 6075 (invisible-p (point))) 6076 (goto-char 6077 (if (get-text-property (point) 'invisible) 6078 (or (next-single-property-change (point) 'invisible) 6079 (point-max)) 6080 (next-overlay-change (point))))) 6081 (unless (bolp) 6082 (goto-char opoint)))) 6083 (let ((first t)) 6084 (while (or first (<= arg 0)) 6085 (if first 6086 (beginning-of-line) 6087 (or (zerop (forward-line -1)) 6088 (signal 'beginning-of-buffer nil))) 6089 ;; If the newline we just moved to is invisible, 6090 ;; don't count it. 6091 (unless (bobp) 6092 (unless (invisible-p (1- (point))) 6093 (setq arg (1+ arg)))) 6094 (setq first nil)) 6095 ;; If invisible text follows, and it is a number of complete lines, 6096 ;; skip it. 6097 (let ((opoint (point))) 6098 (while (and (not (bobp)) 6099 (invisible-p (1- (point)))) 6100 (goto-char 6101 (if (get-text-property (1- (point)) 'invisible) 6102 (or (previous-single-property-change (point) 'invisible) 6103 (point-min)) 6104 (previous-overlay-change (point))))) 6105 (unless (bolp) 6106 (goto-char opoint))))) 6107 ((beginning-of-buffer end-of-buffer) 6108 nil))) 6109 6110(defun end-of-visible-line () 6111 "Move to end of current visible line." 6112 (end-of-line) 6113 ;; If the following character is currently invisible, 6114 ;; skip all characters with that same `invisible' property value, 6115 ;; then find the next newline. 6116 (while (and (not (eobp)) 6117 (save-excursion 6118 (skip-chars-forward "^\n") 6119 (invisible-p (point)))) 6120 (skip-chars-forward "^\n") 6121 (if (get-text-property (point) 'invisible) 6122 (goto-char (or (next-single-property-change (point) 'invisible) 6123 (point-max))) 6124 (goto-char (next-overlay-change (point)))) 6125 (end-of-line))) 6126 6127(defun kill-current-buffer () 6128 "Kill the current buffer. 6129When called in the minibuffer, get out of the minibuffer 6130using `abort-recursive-edit'. 6131 6132This is like `kill-this-buffer', but it doesn't have to be invoked 6133via the menu bar, and pays no attention to the menu-bar's frame." 6134 (interactive) 6135 (let ((frame (selected-frame))) 6136 (if (and (frame-live-p frame) 6137 (not (window-minibuffer-p (frame-selected-window frame)))) 6138 (kill-buffer (current-buffer)) 6139 (abort-recursive-edit)))) 6140 6141 6142(defun insert-buffer (buffer) 6143 "Insert after point the contents of BUFFER. 6144Puts mark after the inserted text. 6145BUFFER may be a buffer or a buffer name." 6146 (declare (interactive-only insert-buffer-substring)) 6147 (interactive 6148 (list 6149 (progn 6150 (barf-if-buffer-read-only) 6151 (read-buffer "Insert buffer: " 6152 (if (eq (selected-window) (next-window)) 6153 (other-buffer (current-buffer)) 6154 (window-buffer (next-window))) 6155 t)))) 6156 (push-mark 6157 (save-excursion 6158 (insert-buffer-substring (get-buffer buffer)) 6159 (point))) 6160 nil) 6161 6162(defun append-to-buffer (buffer start end) 6163 "Append to specified BUFFER the text of the region. 6164The text is inserted into that buffer before its point. 6165BUFFER can be a buffer or the name of a buffer; this 6166function will create BUFFER if it doesn't already exist. 6167 6168When calling from a program, give three arguments: 6169BUFFER (or buffer name), START and END. 6170START and END specify the portion of the current buffer to be copied." 6171 (interactive 6172 (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) t)) 6173 (region-beginning) (region-end))) 6174 (let* ((oldbuf (current-buffer)) 6175 (append-to (get-buffer-create buffer)) 6176 (windows (get-buffer-window-list append-to t t)) 6177 point) 6178 (save-excursion 6179 (with-current-buffer append-to 6180 (setq point (point)) 6181 (barf-if-buffer-read-only) 6182 (insert-buffer-substring oldbuf start end) 6183 (dolist (window windows) 6184 (when (= (window-point window) point) 6185 (set-window-point window (point)))))))) 6186 6187(defun prepend-to-buffer (buffer start end) 6188 "Prepend to specified BUFFER the text of the region. 6189The text is inserted into that buffer after its point. 6190BUFFER can be a buffer or the name of a buffer; this 6191function will create BUFFER if it doesn't already exist. 6192 6193When calling from a program, give three arguments: 6194BUFFER (or buffer name), START and END. 6195START and END specify the portion of the current buffer to be copied." 6196 (interactive "BPrepend to buffer: \nr") 6197 (let ((oldbuf (current-buffer))) 6198 (with-current-buffer (get-buffer-create buffer) 6199 (barf-if-buffer-read-only) 6200 (save-excursion 6201 (insert-buffer-substring oldbuf start end))))) 6202 6203(defun copy-to-buffer (buffer start end) 6204 "Copy to specified BUFFER the text of the region. 6205The text is inserted into that buffer, replacing existing text there. 6206BUFFER can be a buffer or the name of a buffer; this 6207function will create BUFFER if it doesn't already exist. 6208 6209When calling from a program, give three arguments: 6210BUFFER (or buffer name), START and END. 6211START and END specify the portion of the current buffer to be copied." 6212 (interactive "BCopy to buffer: \nr") 6213 (let ((oldbuf (current-buffer))) 6214 (with-current-buffer (get-buffer-create buffer) 6215 (barf-if-buffer-read-only) 6216 (erase-buffer) 6217 (save-excursion 6218 (insert-buffer-substring oldbuf start end))))) 6219 6220(define-error 'mark-inactive (purecopy "The mark is not active now")) 6221 6222(defvar activate-mark-hook nil 6223 "Hook run when the mark becomes active. 6224It is also run when the region is reactivated, for instance after 6225using a command that switches back to a buffer that has an active 6226mark.") 6227 6228(defvar deactivate-mark-hook nil 6229 "Hook run when the mark becomes inactive.") 6230 6231(defun mark (&optional force) 6232 "Return this buffer's mark value as integer, or nil if never set. 6233 6234In Transient Mark mode, this function signals an error if 6235the mark is not active. However, if `mark-even-if-inactive' is non-nil, 6236or the argument FORCE is non-nil, it disregards whether the mark 6237is active, and returns an integer or nil in the usual way. 6238 6239If you are using this in an editing command, you are most likely making 6240a mistake; see the documentation of `set-mark'." 6241 (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive) 6242 (marker-position (mark-marker)) 6243 (signal 'mark-inactive nil))) 6244 6245;; Behind display-selections-p. 6246 6247(defun deactivate-mark (&optional force) 6248 "Deactivate the mark. 6249If Transient Mark mode is disabled, this function normally does 6250nothing; but if FORCE is non-nil, it deactivates the mark anyway. 6251 6252Deactivating the mark sets `mark-active' to nil, updates the 6253primary selection according to `select-active-regions', and runs 6254`deactivate-mark-hook'. 6255 6256If Transient Mark mode was temporarily enabled, reset the value 6257of the variable `transient-mark-mode'; if this causes Transient 6258Mark mode to be disabled, don't change `mark-active' to nil or 6259run `deactivate-mark-hook'." 6260 (when (or (region-active-p) force) 6261 (when (and (if (eq select-active-regions 'only) 6262 (eq (car-safe transient-mark-mode) 'only) 6263 select-active-regions) 6264 (region-active-p) 6265 (display-selections-p)) 6266 ;; The var `saved-region-selection', if non-nil, is the text in 6267 ;; the region prior to the last command modifying the buffer. 6268 ;; Set the selection to that, or to the current region. 6269 (cond (saved-region-selection 6270 (if (gui-backend-selection-owner-p 'PRIMARY) 6271 (gui-set-selection 'PRIMARY saved-region-selection)) 6272 (setq saved-region-selection nil)) 6273 ;; If another program has acquired the selection, region 6274 ;; deactivation should not clobber it (Bug#11772). 6275 ((and (/= (region-beginning) (region-end)) 6276 (or (gui-backend-selection-owner-p 'PRIMARY) 6277 (null (gui-backend-selection-exists-p 'PRIMARY)))) 6278 (gui-set-selection 'PRIMARY 6279 (funcall region-extract-function nil))))) 6280 (when mark-active (force-mode-line-update)) ;Refresh toolbar (bug#16382). 6281 (cond 6282 ((eq (car-safe transient-mark-mode) 'only) 6283 (setq transient-mark-mode (cdr transient-mark-mode)) 6284 (if (eq transient-mark-mode (default-value 'transient-mark-mode)) 6285 (kill-local-variable 'transient-mark-mode))) 6286 ((eq transient-mark-mode 'lambda) 6287 (kill-local-variable 'transient-mark-mode))) 6288 (setq mark-active nil) 6289 (run-hooks 'deactivate-mark-hook) 6290 (redisplay--update-region-highlight (selected-window)))) 6291 6292(defun activate-mark (&optional no-tmm) 6293 "Activate the mark. 6294If NO-TMM is non-nil, leave `transient-mark-mode' alone." 6295 (when (mark t) 6296 (unless (region-active-p) 6297 (force-mode-line-update) ;Refresh toolbar (bug#16382). 6298 (setq mark-active t) 6299 (unless (or transient-mark-mode no-tmm) 6300 (setq-local transient-mark-mode 'lambda)) 6301 (run-hooks 'activate-mark-hook)))) 6302 6303(defun set-mark (pos) 6304 "Set this buffer's mark to POS. Don't use this function! 6305That is to say, don't use this function unless you want 6306the user to see that the mark has moved, and you want the previous 6307mark position to be lost. 6308 6309Normally, when a new mark is set, the old one should go on the stack. 6310This is why most applications should use `push-mark', not `set-mark'. 6311 6312Novice Emacs Lisp programmers often try to use the mark for the wrong 6313purposes. The mark saves a location for the user's convenience. 6314Most editing commands should not alter the mark. 6315To remember a location for internal use in the Lisp program, 6316store it in a Lisp variable. Example: 6317 6318 (let ((beg (point))) (forward-line 1) (delete-region beg (point)))." 6319 (if pos 6320 (progn 6321 (set-marker (mark-marker) pos (current-buffer)) 6322 (activate-mark 'no-tmm)) 6323 ;; Normally we never clear mark-active except in Transient Mark mode. 6324 ;; But when we actually clear out the mark value too, we must 6325 ;; clear mark-active in any mode. 6326 (deactivate-mark t) 6327 ;; `deactivate-mark' sometimes leaves mark-active non-nil, but 6328 ;; it should never be nil if the mark is nil. 6329 (setq mark-active nil) 6330 (set-marker (mark-marker) nil))) 6331 6332(defun save-mark-and-excursion--save () 6333 (cons 6334 (let ((mark (mark-marker))) 6335 (and (marker-position mark) (copy-marker mark))) 6336 mark-active)) 6337 6338(defun save-mark-and-excursion--restore (saved-mark-info) 6339 (let ((saved-mark (car saved-mark-info)) 6340 (omark (marker-position (mark-marker))) 6341 (nmark nil) 6342 (saved-mark-active (cdr saved-mark-info))) 6343 ;; Mark marker 6344 (if (null saved-mark) 6345 (set-marker (mark-marker) nil) 6346 (setf nmark (marker-position saved-mark)) 6347 (set-marker (mark-marker) nmark) 6348 (set-marker saved-mark nil)) 6349 ;; Mark active 6350 (let ((cur-mark-active mark-active)) 6351 (setq mark-active saved-mark-active) 6352 ;; If mark is active now, and either was not active or was at a 6353 ;; different place, run the activate hook. 6354 (if saved-mark-active 6355 (when (or (not cur-mark-active) 6356 (not (eq omark nmark))) 6357 (run-hooks 'activate-mark-hook)) 6358 ;; If mark has ceased to be active, run deactivate hook. 6359 (when cur-mark-active 6360 (run-hooks 'deactivate-mark-hook)))))) 6361 6362(defmacro save-mark-and-excursion (&rest body) 6363 "Like `save-excursion', but also save and restore the mark state. 6364This macro does what `save-excursion' did before Emacs 25.1." 6365 (declare (indent 0) (debug t)) 6366 (let ((saved-marker-sym (make-symbol "saved-marker"))) 6367 `(let ((,saved-marker-sym (save-mark-and-excursion--save))) 6368 (unwind-protect 6369 (save-excursion ,@body) 6370 (save-mark-and-excursion--restore ,saved-marker-sym))))) 6371 6372(defcustom use-empty-active-region nil 6373 "Whether \"region-aware\" commands should act on empty regions. 6374If nil, region-aware commands treat the empty region as inactive. 6375If non-nil, region-aware commands treat the region as active as 6376long as the mark is active, even if the region is empty. 6377 6378Region-aware commands are those that act on the region if it is 6379active and Transient Mark mode is enabled, and on the text near 6380point otherwise." 6381 :type 'boolean 6382 :version "23.1" 6383 :group 'editing-basics) 6384 6385(defun use-region-p () 6386 "Return t if the region is active and it is appropriate to act on it. 6387This is used by commands that act specially on the region under 6388Transient Mark mode. 6389 6390The return value is t if Transient Mark mode is enabled and the 6391mark is active; furthermore, if `use-empty-active-region' is nil, 6392the region must not be empty. Otherwise, the return value is nil. 6393 6394For some commands, it may be appropriate to ignore the value of 6395`use-empty-active-region'; in that case, use `region-active-p'." 6396 (and (region-active-p) 6397 (or use-empty-active-region (> (region-end) (region-beginning))) 6398 t)) 6399 6400(defun region-active-p () 6401 "Return t if Transient Mark mode is enabled and the mark is active. 6402 6403Some commands act specially on the region when Transient Mark 6404mode is enabled. Usually, such commands should use 6405`use-region-p' instead of this function, because `use-region-p' 6406also checks the value of `use-empty-active-region'." 6407 (and transient-mark-mode mark-active 6408 ;; FIXME: Somehow we sometimes end up with mark-active non-nil but 6409 ;; without the mark being set (e.g. bug#17324). We really should fix 6410 ;; that problem, but in the mean time, let's make sure we don't say the 6411 ;; region is active when there's no mark. 6412 (progn (cl-assert (mark)) t))) 6413 6414(defun region-bounds () 6415 "Return the boundaries of the region. 6416Value is a list of one or more cons cells of the form (START . END). 6417It will have more than one cons cell when the region is non-contiguous, 6418see `region-noncontiguous-p' and `extract-rectangle-bounds'." 6419 (funcall region-extract-function 'bounds)) 6420 6421(defun region-noncontiguous-p () 6422 "Return non-nil if the region contains several pieces. 6423An example is a rectangular region handled as a list of 6424separate contiguous regions for each line." 6425 (cdr (region-bounds))) 6426 6427(defvar redisplay-unhighlight-region-function 6428 (lambda (rol) (when (overlayp rol) (delete-overlay rol)))) 6429 6430(defvar redisplay-highlight-region-function 6431 (lambda (start end window rol) 6432 (if (not (overlayp rol)) 6433 (let ((nrol (make-overlay start end))) 6434 (funcall redisplay-unhighlight-region-function rol) 6435 (overlay-put nrol 'window window) 6436 (overlay-put nrol 'face 'region) 6437 ;; Normal priority so that a large region doesn't hide all the 6438 ;; overlays within it, but high secondary priority so that if it 6439 ;; ends/starts in the middle of a small overlay, that small overlay 6440 ;; won't hide the region's boundaries. 6441 (overlay-put nrol 'priority '(nil . 100)) 6442 nrol) 6443 (unless (and (eq (overlay-buffer rol) (current-buffer)) 6444 (eq (overlay-start rol) start) 6445 (eq (overlay-end rol) end)) 6446 (move-overlay rol start end (current-buffer))) 6447 rol)) 6448 "Function to move the region-highlight overlay. 6449This function is called with four parameters, START, END, WINDOW 6450and OVERLAY. If OVERLAY is nil, a new overlay is created. In 6451any case, the overlay is adjusted to reflect the other three 6452parameters. 6453 6454The overlay is returned by the function.") 6455 6456(defun redisplay--update-region-highlight (window) 6457 (let ((rol (window-parameter window 'internal-region-overlay))) 6458 (if (not (and (region-active-p) 6459 (or highlight-nonselected-windows 6460 (eq window (selected-window)) 6461 (and (window-minibuffer-p) 6462 (eq window (minibuffer-selected-window)))))) 6463 (funcall redisplay-unhighlight-region-function rol) 6464 (let* ((pt (window-point window)) 6465 (mark (mark)) 6466 (start (min pt mark)) 6467 (end (max pt mark)) 6468 (new 6469 (funcall redisplay-highlight-region-function 6470 start end window rol))) 6471 (unless (equal new rol) 6472 (set-window-parameter window 'internal-region-overlay 6473 new)))))) 6474 6475(defvar pre-redisplay-functions (list #'redisplay--update-region-highlight) 6476 "Hook run just before redisplay. 6477It is called in each window that is to be redisplayed. It takes one argument, 6478which is the window that will be redisplayed. When run, the `current-buffer' 6479is set to the buffer displayed in that window.") 6480 6481(defun redisplay--pre-redisplay-functions (windows) 6482 (with-demoted-errors "redisplay--pre-redisplay-functions: %S" 6483 (if (null windows) 6484 (with-current-buffer (window-buffer (selected-window)) 6485 (run-hook-with-args 'pre-redisplay-functions (selected-window))) 6486 (dolist (win (if (listp windows) windows (window-list-1 nil nil t))) 6487 (with-current-buffer (window-buffer win) 6488 (run-hook-with-args 'pre-redisplay-functions win)))))) 6489 6490(add-function :before pre-redisplay-function 6491 #'redisplay--pre-redisplay-functions) 6492 6493 6494(defvar-local mark-ring nil 6495 "The list of former marks of the current buffer, most recent first.") 6496(put 'mark-ring 'permanent-local t) 6497 6498(defcustom mark-ring-max 16 6499 "Maximum size of mark ring. Start discarding off end if gets this big." 6500 :type 'integer 6501 :group 'editing-basics) 6502 6503(defvar global-mark-ring nil 6504 "The list of saved global marks, most recent first.") 6505 6506(defcustom global-mark-ring-max 16 6507 "Maximum size of global mark ring. \ 6508Start discarding off end if gets this big." 6509 :type 'integer 6510 :group 'editing-basics) 6511 6512(defun pop-to-mark-command () 6513 "Jump to mark, and pop a new position for mark off the ring. 6514\(Does not affect global mark ring)." 6515 (interactive) 6516 (if (null (mark t)) 6517 (user-error "No mark set in this buffer") 6518 (if (= (point) (mark t)) 6519 (message "Mark popped")) 6520 (goto-char (mark t)) 6521 (pop-mark))) 6522 6523(defun push-mark-command (arg &optional nomsg) 6524 "Set mark at where point is. 6525If no prefix ARG and mark is already set there, just activate it. 6526Display `Mark set' unless the optional second arg NOMSG is non-nil." 6527 (interactive "P") 6528 (let ((mark (mark t))) 6529 (if (or arg (null mark) (/= mark (point))) 6530 (push-mark nil nomsg t) 6531 (activate-mark 'no-tmm) 6532 (unless nomsg 6533 (message "Mark activated"))))) 6534 6535(defcustom set-mark-command-repeat-pop nil 6536 "Non-nil means repeating \\[set-mark-command] after popping mark pops it again. 6537That means that \\[universal-argument] \\[set-mark-command] \\[set-mark-command] 6538will pop the mark twice, and 6539\\[universal-argument] \\[set-mark-command] \\[set-mark-command] \\[set-mark-command] 6540will pop the mark three times. 6541 6542A value of nil means \\[set-mark-command]'s behavior does not change 6543after \\[universal-argument] \\[set-mark-command]." 6544 :type 'boolean 6545 :group 'editing-basics) 6546 6547(defun set-mark-command (arg) 6548 "Set the mark where point is, and activate it; or jump to the mark. 6549Setting the mark also alters the region, which is the text 6550between point and mark; this is the closest equivalent in 6551Emacs to what some editors call the \"selection\". 6552 6553With no prefix argument, set the mark at point, and push the 6554old mark position on local mark ring. Also push the new mark on 6555global mark ring, if the previous mark was set in another buffer. 6556 6557When Transient Mark Mode is off, immediately repeating this 6558command activates `transient-mark-mode' temporarily. 6559 6560With prefix argument (e.g., \\[universal-argument] \\[set-mark-command]), \ 6561jump to the mark, and set the mark from 6562position popped off the local mark ring (this does not affect the global 6563mark ring). Use \\[pop-global-mark] to jump to a mark popped off the global 6564mark ring (see `pop-global-mark'). 6565 6566If `set-mark-command-repeat-pop' is non-nil, repeating 6567the \\[set-mark-command] command with no prefix argument pops the next position 6568off the local (or global) mark ring and jumps there. 6569 6570With \\[universal-argument] \\[universal-argument] as prefix 6571argument, unconditionally set mark where point is, even if 6572`set-mark-command-repeat-pop' is non-nil. 6573 6574Novice Emacs Lisp programmers often try to use the mark for the wrong 6575purposes. See the documentation of `set-mark' for more information." 6576 (interactive "P") 6577 (cond ((eq transient-mark-mode 'lambda) 6578 (kill-local-variable 'transient-mark-mode)) 6579 ((eq (car-safe transient-mark-mode) 'only) 6580 (deactivate-mark))) 6581 (cond 6582 ((and (consp arg) (> (prefix-numeric-value arg) 4)) 6583 (push-mark-command nil)) 6584 ((not (eq this-command 'set-mark-command)) 6585 (if arg 6586 (pop-to-mark-command) 6587 (push-mark-command t))) 6588 ((and set-mark-command-repeat-pop 6589 (eq last-command 'pop-global-mark) 6590 (not arg)) 6591 (setq this-command 'pop-global-mark) 6592 (pop-global-mark)) 6593 ((or (and set-mark-command-repeat-pop 6594 (eq last-command 'pop-to-mark-command)) 6595 arg) 6596 (setq this-command 'pop-to-mark-command) 6597 (pop-to-mark-command)) 6598 ((eq last-command 'set-mark-command) 6599 (if (region-active-p) 6600 (progn 6601 (deactivate-mark) 6602 (message "Mark deactivated")) 6603 (activate-mark) 6604 (message "Mark activated"))) 6605 (t 6606 (push-mark-command nil)))) 6607 6608(defun push-mark (&optional location nomsg activate) 6609 "Set mark at LOCATION (point, by default) and push old mark on mark ring. 6610If the last global mark pushed was not in the current buffer, 6611also push LOCATION on the global mark ring. 6612Display `Mark set' unless the optional second arg NOMSG is non-nil. 6613 6614Novice Emacs Lisp programmers often try to use the mark for the wrong 6615purposes. See the documentation of `set-mark' for more information. 6616 6617In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil." 6618 (when (mark t) 6619 (let ((old (nth mark-ring-max mark-ring)) 6620 (history-delete-duplicates nil)) 6621 (add-to-history 'mark-ring (copy-marker (mark-marker)) mark-ring-max t) 6622 (when old 6623 (set-marker old nil)))) 6624 (set-marker (mark-marker) (or location (point)) (current-buffer)) 6625 ;; Don't push the mark on the global mark ring if the last global 6626 ;; mark pushed was in this same buffer. 6627 (unless (and global-mark-ring 6628 (eq (marker-buffer (car global-mark-ring)) (current-buffer))) 6629 (let ((old (nth global-mark-ring-max global-mark-ring)) 6630 (history-delete-duplicates nil)) 6631 (add-to-history 6632 'global-mark-ring (copy-marker (mark-marker)) global-mark-ring-max t) 6633 (when old 6634 (set-marker old nil)))) 6635 (or nomsg executing-kbd-macro (> (minibuffer-depth) 0) 6636 (message "Mark set")) 6637 (if (or activate (not transient-mark-mode)) 6638 (set-mark (mark t))) 6639 nil) 6640 6641(defun pop-mark () 6642 "Pop off mark ring into the buffer's actual mark. 6643Does not set point. Does nothing if mark ring is empty." 6644 (when mark-ring 6645 (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker))))) 6646 (set-marker (mark-marker) (car mark-ring)) 6647 (set-marker (car mark-ring) nil) 6648 (pop mark-ring)) 6649 (deactivate-mark)) 6650 6651(defun exchange-point-and-mark (&optional arg) 6652 "Put the mark where point is now, and point where the mark is now. 6653This command works even when the mark is not active, 6654and it reactivates the mark. 6655 6656If Transient Mark mode is on, a prefix ARG deactivates the mark 6657if it is active, and otherwise avoids reactivating it. If 6658Transient Mark mode is off, a prefix ARG enables Transient Mark 6659mode temporarily." 6660 (interactive "P") 6661 (let ((omark (mark t)) 6662 (temp-highlight (eq (car-safe transient-mark-mode) 'only))) 6663 (if (null omark) 6664 (user-error "No mark set in this buffer")) 6665 (set-mark (point)) 6666 (goto-char omark) 6667 (cond (temp-highlight 6668 (setq-local transient-mark-mode (cons 'only transient-mark-mode))) 6669 ((xor arg (not (region-active-p))) 6670 (deactivate-mark)) 6671 (t (activate-mark))) 6672 nil)) 6673 6674(defcustom shift-select-mode t 6675 "When non-nil, shifted motion keys activate the mark momentarily. 6676 6677While the mark is activated in this way, any shift-translated point 6678motion key extends the region, and if Transient Mark mode was off, it 6679is temporarily turned on. Furthermore, the mark will be deactivated 6680by any subsequent point motion key that was not shift-translated, or 6681by any action that normally deactivates the mark in Transient Mark mode. 6682 6683When the value is `permanent', the mark will be deactivated by any 6684action which normally does that, but not by motion keys that were 6685not shift-translated. 6686 6687See `this-command-keys-shift-translated' for the meaning of 6688shift-translation." 6689 :type '(choice (const :tag "Off" nil) 6690 (const :tag "Permanent" permanent) 6691 (other :tag "On" t)) 6692 :version "28.1" 6693 :group 'editing-basics) 6694 6695(defun handle-shift-selection () 6696 "Activate/deactivate mark depending on invocation thru shift translation. 6697This function is called by `call-interactively' when a command 6698with a `^' character in its `interactive' spec is invoked, before 6699running the command itself. 6700 6701If `shift-select-mode' is enabled and the command was invoked 6702through shift translation, set the mark and activate the region 6703temporarily, unless it was already set in this way. See 6704`this-command-keys-shift-translated' for the meaning of shift 6705translation. 6706 6707Otherwise, if the region has been activated temporarily, 6708deactivate it, and restore the variable `transient-mark-mode' to 6709its earlier value." 6710 (cond ((and (eq shift-select-mode 'permanent) 6711 this-command-keys-shift-translated) 6712 (unless mark-active 6713 (push-mark nil nil t))) 6714 ((and shift-select-mode 6715 this-command-keys-shift-translated) 6716 (unless (and mark-active 6717 (eq (car-safe transient-mark-mode) 'only)) 6718 (setq-local transient-mark-mode 6719 (cons 'only 6720 (unless (eq transient-mark-mode 'lambda) 6721 transient-mark-mode))) 6722 (push-mark nil nil t))) 6723 ((eq (car-safe transient-mark-mode) 'only) 6724 (setq transient-mark-mode (cdr transient-mark-mode)) 6725 (if (eq transient-mark-mode (default-value 'transient-mark-mode)) 6726 (kill-local-variable 'transient-mark-mode)) 6727 (deactivate-mark)))) 6728 6729(define-minor-mode transient-mark-mode 6730 "Toggle Transient Mark mode. 6731 6732Transient Mark mode is a global minor mode. When enabled, the 6733region is highlighted with the `region' face whenever the mark 6734is active. The mark is \"deactivated\" after certain non-motion 6735commands, including those that change the text in the buffer, and 6736during shift or mouse selection by any unshifted cursor motion 6737command (see Info node `Shift Selection' for more details). 6738 6739You can also deactivate the mark by typing \\[keyboard-quit] or 6740\\[keyboard-escape-quit]. 6741 6742Many commands change their behavior when Transient Mark mode is 6743in effect and the mark is active, by acting on the region instead 6744of their usual default part of the buffer's text. Examples of 6745such commands include \\[comment-dwim], \\[flush-lines], \\[keep-lines], 6746\\[query-replace], \\[query-replace-regexp], \\[ispell], and \\[undo]. 6747To see the documentation of commands that are sensitive to the 6748Transient Mark mode, invoke \\[apropos-documentation] and type \"transient\" 6749or \"mark.*active\" at the prompt." 6750 :global t 6751 ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again. 6752 :variable (default-value 'transient-mark-mode)) 6753 6754(define-minor-mode indent-tabs-mode 6755 "Toggle whether indentation can insert TAB characters." 6756 :global t :group 'indent :variable indent-tabs-mode) 6757 6758(defvar widen-automatically t 6759 "Non-nil means it is ok for commands to call `widen' when they want to. 6760Some commands will do this in order to go to positions outside 6761the current accessible part of the buffer. 6762 6763If `widen-automatically' is nil, these commands will do something else 6764as a fallback, and won't change the buffer bounds.") 6765 6766(defvar non-essential nil 6767 "Whether the currently executing code is performing an essential task. 6768This variable should be non-nil only when running code that should not 6769disturb the user. E.g., it can be used to prevent Tramp from prompting 6770the user for a password when we are simply scanning a set of files in the 6771background or displaying possible completions before the user even asked 6772for it.") 6773 6774(defun pop-global-mark () 6775 "Pop off global mark ring and jump to the top location." 6776 (interactive) 6777 ;; Pop entries that refer to non-existent buffers. 6778 (while (and global-mark-ring (not (marker-buffer (car global-mark-ring)))) 6779 (setq global-mark-ring (cdr global-mark-ring))) 6780 (or global-mark-ring 6781 (error "No global mark set")) 6782 (let* ((marker (car global-mark-ring)) 6783 (buffer (marker-buffer marker)) 6784 (position (marker-position marker))) 6785 (setq global-mark-ring (nconc (cdr global-mark-ring) 6786 (list (car global-mark-ring)))) 6787 (set-buffer buffer) 6788 (or (and (>= position (point-min)) 6789 (<= position (point-max))) 6790 (if widen-automatically 6791 (widen) 6792 (error "Global mark position is outside accessible part of buffer %s" 6793 (buffer-name buffer)))) 6794 (goto-char position) 6795 (switch-to-buffer buffer))) 6796 6797(defcustom next-line-add-newlines nil 6798 "If non-nil, `next-line' inserts newline to avoid `end of buffer' error." 6799 :type 'boolean 6800 :version "21.1" 6801 :group 'editing-basics) 6802 6803(defun next-line (&optional arg try-vscroll) 6804 "Move cursor vertically down ARG lines. 6805Interactively, vscroll tall lines if `auto-window-vscroll' is enabled. 6806Non-interactively, use TRY-VSCROLL to control whether to vscroll tall 6807lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this 6808function will not vscroll. 6809 6810ARG defaults to 1. 6811 6812If there is no character in the target line exactly under the current column, 6813the cursor is positioned after the character in that line that spans this 6814column, or at the end of the line if it is not long enough. 6815If there is no line in the buffer after this one, behavior depends on the 6816value of `next-line-add-newlines'. If non-nil, it inserts a newline character 6817to create a line, and moves the cursor to that line. Otherwise it moves the 6818cursor to the end of the buffer. 6819 6820If the variable `line-move-visual' is non-nil, this command moves 6821by display lines. Otherwise, it moves by buffer lines, without 6822taking variable-width characters or continued lines into account. 6823See \\[next-logical-line] for a command that always moves by buffer lines. 6824 6825The command \\[set-goal-column] can be used to create 6826a semipermanent goal column for this command. 6827Then instead of trying to move exactly vertically (or as close as possible), 6828this command moves to the specified goal column (or as close as possible). 6829The goal column is stored in the variable `goal-column', which is nil 6830when there is no goal column. Note that setting `goal-column' 6831overrides `line-move-visual' and causes this command to move by buffer 6832lines rather than by display lines." 6833 (declare (interactive-only forward-line)) 6834 (interactive "^p\np") 6835 (or arg (setq arg 1)) 6836 (if (and next-line-add-newlines (= arg 1)) 6837 (if (save-excursion (end-of-line) (eobp)) 6838 ;; When adding a newline, don't expand an abbrev. 6839 (let ((abbrev-mode nil)) 6840 (end-of-line) 6841 (insert (if use-hard-newlines hard-newline "\n"))) 6842 (line-move arg nil nil try-vscroll)) 6843 (if (called-interactively-p 'interactive) 6844 (condition-case err 6845 (line-move arg nil nil try-vscroll) 6846 ((beginning-of-buffer end-of-buffer) 6847 (signal (car err) (cdr err)))) 6848 (line-move arg nil nil try-vscroll))) 6849 nil) 6850 6851(defun previous-line (&optional arg try-vscroll) 6852 "Move cursor vertically up ARG lines. 6853Interactively, vscroll tall lines if `auto-window-vscroll' is enabled. 6854Non-interactively, use TRY-VSCROLL to control whether to vscroll tall 6855lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this 6856function will not vscroll. 6857 6858ARG defaults to 1. 6859 6860If there is no character in the target line exactly over the current column, 6861the cursor is positioned after the character in that line that spans this 6862column, or at the end of the line if it is not long enough. 6863 6864If the variable `line-move-visual' is non-nil, this command moves 6865by display lines. Otherwise, it moves by buffer lines, without 6866taking variable-width characters or continued lines into account. 6867See \\[previous-logical-line] for a command that always moves by buffer lines. 6868 6869The command \\[set-goal-column] can be used to create 6870a semipermanent goal column for this command. 6871Then instead of trying to move exactly vertically (or as close as possible), 6872this command moves to the specified goal column (or as close as possible). 6873The goal column is stored in the variable `goal-column', which is nil 6874when there is no goal column. Note that setting `goal-column' 6875overrides `line-move-visual' and causes this command to move by buffer 6876lines rather than by display lines." 6877 (declare (interactive-only 6878 "use `forward-line' with negative argument instead.")) 6879 (interactive "^p\np") 6880 (or arg (setq arg 1)) 6881 (if (called-interactively-p 'interactive) 6882 (condition-case err 6883 (line-move (- arg) nil nil try-vscroll) 6884 ((beginning-of-buffer end-of-buffer) 6885 (signal (car err) (cdr err)))) 6886 (line-move (- arg) nil nil try-vscroll)) 6887 nil) 6888 6889(defcustom track-eol nil 6890 "Non-nil means vertical motion starting at end of line keeps to ends of lines. 6891This means moving to the end of each line moved onto. 6892The beginning of a blank line does not count as the end of a line. 6893This has no effect when the variable `line-move-visual' is non-nil." 6894 :type 'boolean 6895 :group 'editing-basics) 6896 6897(defcustom goal-column nil 6898 "Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil. 6899A non-nil setting overrides the variable `line-move-visual', which see." 6900 :type '(choice integer 6901 (const :tag "None" nil)) 6902 :group 'editing-basics) 6903(make-variable-buffer-local 'goal-column) 6904 6905(defvar temporary-goal-column 0 6906 "Current goal column for vertical motion. 6907It is the column where point was at the start of the current run 6908of vertical motion commands. 6909 6910When moving by visual lines via the function `line-move-visual', it is a cons 6911cell (COL . HSCROLL), where COL is the x-position, in pixels, 6912divided by the default column width, and HSCROLL is the number of 6913columns by which window is scrolled from left margin. 6914 6915When the `track-eol' feature is doing its job, the value is 6916`most-positive-fixnum'.") 6917 6918(defcustom line-move-ignore-invisible t 6919 "Non-nil means commands that move by lines ignore invisible newlines. 6920When this option is non-nil, \\[next-line], \\[previous-line], \\[move-end-of-line], and \\[move-beginning-of-line] behave 6921as if newlines that are invisible didn't exist, and count 6922only visible newlines. Thus, moving across 2 newlines 6923one of which is invisible will be counted as a one-line move. 6924Also, a non-nil value causes invisible text to be ignored when 6925counting columns for the purposes of keeping point in the same 6926column by \\[next-line] and \\[previous-line]. 6927 6928Outline mode sets this." 6929 :type 'boolean 6930 :group 'editing-basics) 6931 6932(defcustom line-move-visual t 6933 "When non-nil, `line-move' moves point by visual lines. 6934This movement is based on where the cursor is displayed on the 6935screen, instead of relying on buffer contents alone. It takes 6936into account variable-width characters and line continuation. 6937If nil, `line-move' moves point by logical lines. 6938A non-nil setting of `goal-column' overrides the value of this variable 6939and forces movement by logical lines. 6940A window that is horizontally scrolled also forces movement by logical 6941lines." 6942 :type 'boolean 6943 :group 'editing-basics 6944 :version "23.1") 6945 6946;; Used only if display-graphic-p. 6947(declare-function font-info "font.c" (name &optional frame)) 6948 6949(defun default-font-height () 6950 "Return the height in pixels of the current buffer's default face font. 6951 6952If the default font is remapped (see `face-remapping-alist'), the 6953function returns the height of the remapped face. 6954This function uses the definition of the default face for the currently 6955selected frame." 6956 (let ((default-font (face-font 'default))) 6957 (cond 6958 ((and (display-multi-font-p) 6959 ;; Avoid calling font-info if the frame's default font was 6960 ;; not changed since the frame was created. That's because 6961 ;; font-info is expensive for some fonts, see bug #14838. 6962 (not (string= (frame-parameter nil 'font) default-font))) 6963 (aref (font-info default-font) 3)) 6964 (t (frame-char-height))))) 6965 6966(defun default-font-width () 6967 "Return the width in pixels of the current buffer's default face font. 6968 6969If the default font is remapped (see `face-remapping-alist'), the 6970function returns the width of the remapped face. 6971This function uses the definition of the default face for the currently 6972selected frame." 6973 (let ((default-font (face-font 'default))) 6974 (cond 6975 ((and (display-multi-font-p) 6976 ;; Avoid calling font-info if the frame's default font was 6977 ;; not changed since the frame was created. That's because 6978 ;; font-info is expensive for some fonts, see bug #14838. 6979 (not (string= (frame-parameter nil 'font) default-font))) 6980 (let* ((info (font-info (face-font 'default))) 6981 (width (aref info 11))) 6982 (if (> width 0) 6983 width 6984 (aref info 10)))) 6985 (t (frame-char-width))))) 6986 6987(defun default-line-height () 6988 "Return the pixel height of current buffer's default-face text line. 6989 6990The value includes `line-spacing', if any, defined for the buffer 6991or the frame. 6992This function uses the definition of the default face for the currently 6993selected frame." 6994 (let ((dfh (default-font-height)) 6995 (lsp (if (display-graphic-p) 6996 (or line-spacing 6997 (default-value 'line-spacing) 6998 (frame-parameter nil 'line-spacing) 6999 0) 7000 0))) 7001 (if (floatp lsp) 7002 (setq lsp (truncate (* (frame-char-height) lsp)))) 7003 (+ dfh lsp))) 7004 7005(defun window-screen-lines () 7006 "Return the number of screen lines in the text area of the selected window. 7007 7008This is different from `window-text-height' in that this function counts 7009lines in units of the height of the font used by the default face displayed 7010in the window, not in units of the frame's default font, and also accounts 7011for `line-spacing', if any, defined for the window's buffer or frame. 7012 7013The value is a floating-point number." 7014 (let ((edges (window-inside-pixel-edges)) 7015 (dlh (default-line-height))) 7016 (/ (float (- (nth 3 edges) (nth 1 edges))) dlh))) 7017 7018;; Returns non-nil if partial move was done. 7019(defun line-move-partial (arg noerror &optional _to-end) 7020 (if (< arg 0) 7021 ;; Move backward (up). 7022 ;; If already vscrolled, reduce vscroll 7023 (let ((vs (window-vscroll nil t)) 7024 (dlh (default-line-height))) 7025 (when (> vs dlh) 7026 (set-window-vscroll nil (- vs dlh) t))) 7027 7028 ;; Move forward (down). 7029 (let* ((lh (window-line-height -1)) 7030 (rowh (car lh)) 7031 (vpos (nth 1 lh)) 7032 (ypos (nth 2 lh)) 7033 (rbot (nth 3 lh)) 7034 (this-lh (window-line-height)) 7035 (this-height (car this-lh)) 7036 (this-ypos (nth 2 this-lh)) 7037 (dlh (default-line-height)) 7038 (wslines (window-screen-lines)) 7039 (edges (window-inside-pixel-edges)) 7040 (winh (- (nth 3 edges) (nth 1 edges) 1)) 7041 py vs last-line) 7042 (if (> (mod wslines 1.0) 0.0) 7043 (setq wslines (round (+ wslines 0.5)))) 7044 (when (or (null lh) 7045 (>= rbot dlh) 7046 (<= ypos (- dlh)) 7047 (null this-lh) 7048 (<= this-ypos (- dlh))) 7049 (unless lh 7050 (let ((wend (pos-visible-in-window-p t nil t))) 7051 (setq rbot (nth 3 wend) 7052 rowh (nth 4 wend) 7053 vpos (nth 5 wend)))) 7054 (unless this-lh 7055 (let ((wstart (pos-visible-in-window-p nil nil t))) 7056 (setq this-ypos (nth 2 wstart) 7057 this-height (nth 4 wstart)))) 7058 (setq py 7059 (or (nth 1 this-lh) 7060 (let ((ppos (posn-at-point)) 7061 col-row) 7062 (setq col-row (posn-actual-col-row ppos)) 7063 (if col-row 7064 (- (cdr col-row) (window-vscroll)) 7065 (cdr (posn-col-row ppos)))))) 7066 ;; VPOS > 0 means the last line is only partially visible. 7067 ;; But if the part that is visible is at least as tall as the 7068 ;; default font, that means the line is actually fully 7069 ;; readable, and something like line-spacing is hidden. So in 7070 ;; that case we accept the last line in the window as still 7071 ;; visible, and consider the margin as starting one line 7072 ;; later. 7073 (if (and vpos (> vpos 0)) 7074 (if (and rowh 7075 (>= rowh (default-font-height)) 7076 (< rowh dlh)) 7077 (setq last-line (min (- wslines scroll-margin) vpos)) 7078 (setq last-line (min (- wslines scroll-margin 1) (1- vpos))))) 7079 (cond 7080 ;; If last line of window is fully visible, and vscrolling 7081 ;; more would make this line invisible, move forward. 7082 ((and (or (< (setq vs (window-vscroll nil t)) dlh) 7083 (null this-height) 7084 (<= this-height dlh)) 7085 (or (null rbot) (= rbot 0))) 7086 nil) 7087 ;; If cursor is not in the bottom scroll margin, and the 7088 ;; current line is not too tall, or if there's a continuation 7089 ;; line below this one, move forward. 7090 ((and (or (null this-height) (<= this-height winh)) 7091 vpos 7092 (> vpos 0) 7093 (or (< py last-line) 7094 (display--line-is-continued-p))) 7095 nil) 7096 ;; When already vscrolled, we vscroll some more if we can, 7097 ;; or clear vscroll and move forward at end of tall image. 7098 ((> vs 0) 7099 (when (or (and rbot (> rbot 0)) 7100 (and this-height (> this-height dlh))) 7101 (set-window-vscroll nil (+ vs dlh) t))) 7102 ;; If cursor just entered the bottom scroll margin, move forward, 7103 ;; but also optionally vscroll one line so redisplay won't recenter. 7104 ((and vpos 7105 (> vpos 0) 7106 (= py last-line)) 7107 ;; Don't vscroll if the partially-visible line at window 7108 ;; bottom is not too tall (a.k.a. "just one more text 7109 ;; line"): in that case, we do want redisplay to behave 7110 ;; normally, i.e. recenter or whatever. 7111 ;; 7112 ;; Note: ROWH + RBOT from the value returned by 7113 ;; pos-visible-in-window-p give the total height of the 7114 ;; partially-visible glyph row at the end of the window. As 7115 ;; we are dealing with floats, we disregard sub-pixel 7116 ;; discrepancies between that and DLH. 7117 (if (and rowh rbot (>= (- (+ rowh rbot) winh) 1)) 7118 (set-window-vscroll nil dlh t)) 7119 (line-move-1 arg noerror) 7120 t) 7121 ;; If there are lines above the last line, scroll-up one line. 7122 ((and vpos (> vpos 0)) 7123 (scroll-up 1) 7124 t) 7125 ;; Finally, start vscroll. 7126 (t 7127 (set-window-vscroll nil dlh t))))))) 7128 7129 7130;; This is like line-move-1 except that it also performs 7131;; vertical scrolling of tall images if appropriate. 7132;; That is not really a clean thing to do, since it mixes 7133;; scrolling with cursor motion. But so far we don't have 7134;; a cleaner solution to the problem of making C-n do something 7135;; useful given a tall image. 7136(defun line-move (arg &optional noerror _to-end try-vscroll) 7137 "Move forward ARG lines. 7138If NOERROR, don't signal an error if we can't move ARG lines. 7139TO-END is unused. 7140TRY-VSCROLL controls whether to vscroll tall lines: if either 7141`auto-window-vscroll' or TRY-VSCROLL is nil, this function will 7142not vscroll." 7143 (if noninteractive 7144 (line-move-1 arg noerror) 7145 (unless (and auto-window-vscroll try-vscroll 7146 ;; Only vscroll for single line moves 7147 (= (abs arg) 1) 7148 ;; Under scroll-conservatively, the display engine 7149 ;; does this better. 7150 (zerop scroll-conservatively) 7151 ;; But don't vscroll in a keyboard macro. 7152 (not defining-kbd-macro) 7153 (not executing-kbd-macro) 7154 (line-move-partial arg noerror)) 7155 (set-window-vscroll nil 0 t) 7156 (if (and line-move-visual 7157 ;; Display-based column are incompatible with goal-column. 7158 (not goal-column) 7159 ;; When the text in the window is scrolled to the left, 7160 ;; display-based motion doesn't make sense (because each 7161 ;; logical line occupies exactly one screen line). 7162 (not (> (window-hscroll) 0)) 7163 ;; Likewise when the text _was_ scrolled to the left 7164 ;; when the current run of vertical motion commands 7165 ;; started. 7166 (not (and (memq last-command 7167 `(next-line previous-line ,this-command)) 7168 auto-hscroll-mode 7169 (numberp temporary-goal-column) 7170 (>= temporary-goal-column 7171 (- (window-width) hscroll-margin))))) 7172 (prog1 (line-move-visual arg noerror) 7173 ;; If we moved into a tall line, set vscroll to make 7174 ;; scrolling through tall images more smooth. 7175 (let ((lh (line-pixel-height)) 7176 (edges (window-inside-pixel-edges)) 7177 (dlh (default-line-height)) 7178 winh) 7179 (setq winh (- (nth 3 edges) (nth 1 edges) 1)) 7180 (if (and (< arg 0) 7181 (< (point) (window-start)) 7182 (> lh winh)) 7183 (set-window-vscroll 7184 nil 7185 (- lh dlh) t)))) 7186 (line-move-1 arg noerror))))) 7187 7188;; Display-based alternative to line-move-1. 7189;; Arg says how many lines to move. The value is t if we can move the 7190;; specified number of lines. 7191(defun line-move-visual (arg &optional noerror) 7192 "Move ARG lines forward. 7193If NOERROR, don't signal an error if we can't move that many lines." 7194 (let ((opoint (point)) 7195 (hscroll (window-hscroll)) 7196 (lnum-width (line-number-display-width t)) 7197 target-hscroll) 7198 ;; Check if the previous command was a line-motion command, or if 7199 ;; we were called from some other command. 7200 (if (and (consp temporary-goal-column) 7201 (memq last-command `(next-line previous-line ,this-command))) 7202 ;; If so, there's no need to reset `temporary-goal-column', 7203 ;; but we may need to hscroll. 7204 (if (or (/= (cdr temporary-goal-column) hscroll) 7205 (> (cdr temporary-goal-column) 0)) 7206 (setq target-hscroll (cdr temporary-goal-column))) 7207 ;; Otherwise, we should reset `temporary-goal-column'. 7208 (let ((posn (posn-at-point)) 7209 x-pos) 7210 (cond 7211 ;; Handle the `overflow-newline-into-fringe' case 7212 ;; (left-fringe is for the R2L case): 7213 ((memq (nth 1 posn) '(right-fringe left-fringe)) 7214 (setq temporary-goal-column (cons (window-width) hscroll))) 7215 ((car (posn-x-y posn)) 7216 (setq x-pos (- (car (posn-x-y posn)) lnum-width)) 7217 ;; In R2L lines, the X pixel coordinate is measured from the 7218 ;; left edge of the window, but columns are still counted 7219 ;; from the logical-order beginning of the line, i.e. from 7220 ;; the right edge in this case. We need to adjust for that. 7221 (if (eq (current-bidi-paragraph-direction) 'right-to-left) 7222 (setq x-pos (- (window-body-width nil t) 1 x-pos))) 7223 (setq temporary-goal-column 7224 (cons (/ (float x-pos) 7225 (frame-char-width)) 7226 hscroll))) 7227 (executing-kbd-macro 7228 ;; When we move beyond the first/last character visible in 7229 ;; the window, posn-at-point will return nil, so we need to 7230 ;; approximate the goal column as below. 7231 (setq temporary-goal-column 7232 (mod (current-column) (window-text-width))))))) 7233 (if target-hscroll 7234 (set-window-hscroll (selected-window) target-hscroll)) 7235 ;; vertical-motion can move more than it was asked to if it moves 7236 ;; across display strings with newlines. We don't want to ring 7237 ;; the bell and announce beginning/end of buffer in that case. 7238 (or (and (or (and (>= arg 0) 7239 (>= (vertical-motion 7240 (cons (or goal-column 7241 (if (consp temporary-goal-column) 7242 (car temporary-goal-column) 7243 temporary-goal-column)) 7244 arg)) 7245 arg)) 7246 (and (< arg 0) 7247 (<= (vertical-motion 7248 (cons (or goal-column 7249 (if (consp temporary-goal-column) 7250 (car temporary-goal-column) 7251 temporary-goal-column)) 7252 arg)) 7253 arg))) 7254 (or (>= arg 0) 7255 (/= (point) opoint) 7256 ;; If the goal column lies on a display string, 7257 ;; `vertical-motion' advances the cursor to the end 7258 ;; of the string. For arg < 0, this can cause the 7259 ;; cursor to get stuck. (Bug#3020). 7260 (= (vertical-motion arg) arg))) 7261 (unless noerror 7262 (signal (if (< arg 0) 'beginning-of-buffer 'end-of-buffer) 7263 nil))))) 7264 7265;; This is the guts of next-line and previous-line. 7266;; Arg says how many lines to move. 7267;; The value is t if we can move the specified number of lines. 7268(defun line-move-1 (arg &optional noerror _to-end) 7269 ;; Don't run any point-motion hooks, and disregard intangibility, 7270 ;; for intermediate positions. 7271 (let ((inhibit-point-motion-hooks t) 7272 (opoint (point)) 7273 (orig-arg arg)) 7274 (if (consp temporary-goal-column) 7275 (setq temporary-goal-column (+ (car temporary-goal-column) 7276 (cdr temporary-goal-column)))) 7277 (unwind-protect 7278 (progn 7279 (if (not (memq last-command '(next-line previous-line))) 7280 (setq temporary-goal-column 7281 (if (and track-eol (eolp) 7282 ;; Don't count beg of empty line as end of line 7283 ;; unless we just did explicit end-of-line. 7284 (or (not (bolp)) (eq last-command 'move-end-of-line))) 7285 most-positive-fixnum 7286 (current-column)))) 7287 7288 (if (not (or (integerp selective-display) 7289 line-move-ignore-invisible)) 7290 ;; Use just newline characters. 7291 ;; Set ARG to 0 if we move as many lines as requested. 7292 (or (if (> arg 0) 7293 (progn (if (> arg 1) (forward-line (1- arg))) 7294 ;; This way of moving forward ARG lines 7295 ;; verifies that we have a newline after the last one. 7296 ;; It doesn't get confused by intangible text. 7297 (end-of-line) 7298 (if (zerop (forward-line 1)) 7299 (setq arg 0))) 7300 (and (zerop (forward-line arg)) 7301 (bolp) 7302 (setq arg 0))) 7303 (unless noerror 7304 (signal (if (< arg 0) 7305 'beginning-of-buffer 7306 'end-of-buffer) 7307 nil))) 7308 ;; Move by arg lines, but ignore invisible ones. 7309 (let (done) 7310 (while (and (> arg 0) (not done)) 7311 ;; If the following character is currently invisible, 7312 ;; skip all characters with that same `invisible' property value. 7313 (while (and (not (eobp)) (invisible-p (point))) 7314 (goto-char (next-char-property-change (point)))) 7315 ;; Move a line. 7316 ;; We don't use `end-of-line', since we want to escape 7317 ;; from field boundaries occurring exactly at point. 7318 (goto-char (constrain-to-field 7319 (let ((inhibit-field-text-motion t)) 7320 (line-end-position)) 7321 (point) t t 7322 'inhibit-line-move-field-capture)) 7323 ;; If there's no invisibility here, move over the newline. 7324 (cond 7325 ((eobp) 7326 (if (not noerror) 7327 (signal 'end-of-buffer nil) 7328 (setq done t))) 7329 ((and (> arg 1) ;; Use vertical-motion for last move 7330 (not (integerp selective-display)) 7331 (not (invisible-p (point)))) 7332 ;; We avoid vertical-motion when possible 7333 ;; because that has to fontify. 7334 (forward-line 1)) 7335 ;; Otherwise move a more sophisticated way. 7336 ((zerop (vertical-motion 1)) 7337 (if (not noerror) 7338 (signal 'end-of-buffer nil) 7339 (setq done t)))) 7340 (unless done 7341 (setq arg (1- arg)))) 7342 ;; The logic of this is the same as the loop above, 7343 ;; it just goes in the other direction. 7344 (while (and (< arg 0) (not done)) 7345 ;; For completely consistency with the forward-motion 7346 ;; case, we should call beginning-of-line here. 7347 ;; However, if point is inside a field and on a 7348 ;; continued line, the call to (vertical-motion -1) 7349 ;; below won't move us back far enough; then we return 7350 ;; to the same column in line-move-finish, and point 7351 ;; gets stuck -- cyd 7352 (forward-line 0) 7353 (cond 7354 ((bobp) 7355 (if (not noerror) 7356 (signal 'beginning-of-buffer nil) 7357 (setq done t))) 7358 ((and (< arg -1) ;; Use vertical-motion for last move 7359 (not (integerp selective-display)) 7360 (not (invisible-p (1- (point))))) 7361 (forward-line -1)) 7362 ((zerop (vertical-motion -1)) 7363 (if (not noerror) 7364 (signal 'beginning-of-buffer nil) 7365 (setq done t)))) 7366 (unless done 7367 (setq arg (1+ arg)) 7368 (while (and ;; Don't move over previous invis lines 7369 ;; if our target is the middle of this line. 7370 (or (zerop (or goal-column temporary-goal-column)) 7371 (< arg 0)) 7372 (not (bobp)) (invisible-p (1- (point)))) 7373 (goto-char (previous-char-property-change (point)))))))) 7374 ;; This is the value the function returns. 7375 (= arg 0)) 7376 7377 (cond ((> arg 0) 7378 ;; If we did not move down as far as desired, at least go 7379 ;; to end of line. Be sure to call point-entered and 7380 ;; point-left-hooks. 7381 (let* ((npoint (prog1 (line-end-position) 7382 (goto-char opoint))) 7383 (inhibit-point-motion-hooks nil)) 7384 (goto-char npoint))) 7385 ((< arg 0) 7386 ;; If we did not move up as far as desired, 7387 ;; at least go to beginning of line. 7388 (let* ((npoint (prog1 (line-beginning-position) 7389 (goto-char opoint))) 7390 (inhibit-point-motion-hooks nil)) 7391 (goto-char npoint))) 7392 (t 7393 (line-move-finish (or goal-column temporary-goal-column) 7394 opoint (> orig-arg 0))))))) 7395 7396(defun line-move-finish (column opoint forward) 7397 (let ((repeat t)) 7398 (while repeat 7399 ;; Set REPEAT to t to repeat the whole thing. 7400 (setq repeat nil) 7401 7402 (let (new 7403 (old (point)) 7404 (line-beg (line-beginning-position)) 7405 (line-end 7406 ;; Compute the end of the line 7407 ;; ignoring effectively invisible newlines. 7408 (save-excursion 7409 ;; Like end-of-line but ignores fields. 7410 (skip-chars-forward "^\n") 7411 (while (and (not (eobp)) (invisible-p (point))) 7412 (goto-char (next-char-property-change (point))) 7413 (skip-chars-forward "^\n")) 7414 (point)))) 7415 7416 ;; Move to the desired column. 7417 (if (and line-move-visual 7418 (not (or truncate-lines truncate-partial-width-windows))) 7419 ;; Under line-move-visual, goal-column should be 7420 ;; interpreted in units of the frame's canonical character 7421 ;; width, which is exactly what vertical-motion does. 7422 (vertical-motion (cons column 0)) 7423 (line-move-to-column (truncate column))) 7424 7425 ;; Corner case: suppose we start out in a field boundary in 7426 ;; the middle of a continued line. When we get to 7427 ;; line-move-finish, point is at the start of a new *screen* 7428 ;; line but the same text line; then line-move-to-column would 7429 ;; move us backwards. Test using C-n with point on the "x" in 7430 ;; (insert "a" (propertize "x" 'field t) (make-string 89 ?y)) 7431 (and forward 7432 (< (point) old) 7433 (goto-char old)) 7434 7435 (setq new (point)) 7436 7437 ;; Process intangibility within a line. 7438 ;; With inhibit-point-motion-hooks bound to nil, a call to 7439 ;; goto-char moves point past intangible text. 7440 7441 ;; However, inhibit-point-motion-hooks controls both the 7442 ;; intangibility and the point-entered/point-left hooks. The 7443 ;; following hack avoids calling the point-* hooks 7444 ;; unnecessarily. Note that we move *forward* past intangible 7445 ;; text when the initial and final points are the same. 7446 (goto-char new) 7447 (let ((inhibit-point-motion-hooks nil)) 7448 (goto-char new) 7449 7450 ;; If intangibility moves us to a different (later) place 7451 ;; in the same line, use that as the destination. 7452 (if (<= (point) line-end) 7453 (setq new (point)) 7454 ;; If that position is "too late", 7455 ;; try the previous allowable position. 7456 ;; See if it is ok. 7457 (backward-char) 7458 (if (if forward 7459 ;; If going forward, don't accept the previous 7460 ;; allowable position if it is before the target line. 7461 (< line-beg (point)) 7462 ;; If going backward, don't accept the previous 7463 ;; allowable position if it is still after the target line. 7464 (<= (point) line-end)) 7465 (setq new (point)) 7466 ;; As a last resort, use the end of the line. 7467 (setq new line-end)))) 7468 7469 ;; Now move to the updated destination, processing fields 7470 ;; as well as intangibility. 7471 (goto-char opoint) 7472 (let ((inhibit-point-motion-hooks nil)) 7473 (goto-char 7474 ;; Ignore field boundaries if the initial and final 7475 ;; positions have the same `field' property, even if the 7476 ;; fields are non-contiguous. This seems to be "nicer" 7477 ;; behavior in many situations. 7478 (if (eq (get-char-property new 'field) 7479 (get-char-property opoint 'field)) 7480 new 7481 (constrain-to-field new opoint t t 7482 'inhibit-line-move-field-capture)))) 7483 7484 ;; If all this moved us to a different line, 7485 ;; retry everything within that new line. 7486 (when (or (< (point) line-beg) (> (point) line-end)) 7487 ;; Repeat the intangibility and field processing. 7488 (setq repeat t)))))) 7489 7490(defun line-move-to-column (col) 7491 "Try to find column COL, considering invisibility. 7492This function works only in certain cases, 7493because what we really need is for `move-to-column' 7494and `current-column' to be able to ignore invisible text." 7495 (if (zerop col) 7496 (beginning-of-line) 7497 (move-to-column col)) 7498 7499 (when (and line-move-ignore-invisible 7500 (not (bolp)) (invisible-p (1- (point)))) 7501 (let ((normal-location (point)) 7502 (normal-column (current-column))) 7503 ;; If the following character is currently invisible, 7504 ;; skip all characters with that same `invisible' property value. 7505 (while (and (not (eobp)) 7506 (invisible-p (point))) 7507 (goto-char (next-char-property-change (point)))) 7508 ;; Have we advanced to a larger column position? 7509 (if (> (current-column) normal-column) 7510 ;; We have made some progress towards the desired column. 7511 ;; See if we can make any further progress. 7512 (line-move-to-column (+ (current-column) (- col normal-column))) 7513 ;; Otherwise, go to the place we originally found 7514 ;; and move back over invisible text. 7515 ;; that will get us to the same place on the screen 7516 ;; but with a more reasonable buffer position. 7517 (goto-char normal-location) 7518 (let ((line-beg 7519 ;; We want the real line beginning, so it's consistent 7520 ;; with bolp below, otherwise we might infloop. 7521 (let ((inhibit-field-text-motion t)) 7522 (line-beginning-position)))) 7523 (while (and (not (bolp)) (invisible-p (1- (point)))) 7524 (goto-char (previous-char-property-change (point) line-beg)))))))) 7525 7526(defun move-end-of-line (arg) 7527 "Move point to end of current line as displayed. 7528With argument ARG not nil or 1, move forward ARG - 1 lines first. 7529If point reaches the beginning or end of buffer, it stops there. 7530 7531To ignore the effects of the `intangible' text or overlay 7532property, bind `inhibit-point-motion-hooks' to t. 7533If there is an image in the current line, this function 7534disregards newlines that are part of the text on which the image 7535rests." 7536 (interactive "^p") 7537 (or arg (setq arg 1)) 7538 (let (done) 7539 (while (not done) 7540 (let ((newpos 7541 (save-excursion 7542 (let ((goal-column 0) 7543 (line-move-visual nil)) 7544 (and (line-move arg t) 7545 ;; With bidi reordering, we may not be at bol, 7546 ;; so make sure we are. 7547 (skip-chars-backward "^\n") 7548 (not (bobp)) 7549 (progn 7550 (while (and (not (bobp)) (invisible-p (1- (point)))) 7551 (goto-char (previous-single-char-property-change 7552 (point) 'invisible))) 7553 (backward-char 1))) 7554 (point))))) 7555 (goto-char newpos) 7556 (if (and (> (point) newpos) 7557 (eq (preceding-char) ?\n)) 7558 (backward-char 1) 7559 (if (and (> (point) newpos) (not (eobp)) 7560 (not (eq (following-char) ?\n))) 7561 ;; If we skipped something intangible and now we're not 7562 ;; really at eol, keep going. 7563 (setq arg 1) 7564 (setq done t))))))) 7565 7566(defun move-beginning-of-line (arg) 7567 "Move point to visible beginning of current logical line. 7568This disregards any invisible newline characters. 7569 7570When moving from position that has no `field' property, this 7571command doesn't enter text which has non-nil `field' property. 7572In particular, when invoked in the minibuffer, the command will 7573stop short of entering the text of the minibuffer prompt. 7574See `inhibit-field-text-motion' for how to inhibit this. 7575 7576With argument ARG not nil or 1, move forward ARG - 1 lines first. 7577If point reaches the beginning or end of buffer, it stops there. 7578\(But if the buffer doesn't end in a newline, it stops at the 7579beginning of the last line.) 7580 7581To ignore intangibility, bind `inhibit-point-motion-hooks' to t. 7582For motion by visual lines, see `beginning-of-visual-line'." 7583 (interactive "^p") 7584 (or arg (setq arg 1)) 7585 7586 (let ((orig (point)) 7587 first-vis first-vis-field-value) 7588 7589 ;; Move by lines, if ARG is not 1 (the default). 7590 (if (/= arg 1) 7591 (let ((line-move-visual nil)) 7592 (line-move (1- arg) t))) 7593 7594 ;; Move to beginning-of-line, ignoring fields and invisible text. 7595 (skip-chars-backward "^\n") 7596 (while (and (not (bobp)) (invisible-p (1- (point)))) 7597 (goto-char (previous-char-property-change (point))) 7598 (skip-chars-backward "^\n")) 7599 7600 ;; Now find first visible char in the line. 7601 (while (and (< (point) orig) (invisible-p (point))) 7602 (goto-char (next-char-property-change (point) orig))) 7603 (setq first-vis (point)) 7604 7605 ;; See if fields would stop us from reaching FIRST-VIS. 7606 (setq first-vis-field-value 7607 (constrain-to-field first-vis orig (/= arg 1) t nil)) 7608 7609 (goto-char (if (/= first-vis-field-value first-vis) 7610 ;; If yes, obey them. 7611 first-vis-field-value 7612 ;; Otherwise, move to START with attention to fields. 7613 ;; (It is possible that fields never matter in this case.) 7614 (constrain-to-field (point) orig 7615 (/= arg 1) t nil))))) 7616 7617 7618;; Many people have said they rarely use this feature, and often type 7619;; it by accident. Maybe it shouldn't even be on a key. 7620(put 'set-goal-column 'disabled t) 7621 7622(defun set-goal-column (arg) 7623 "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line]. 7624Those commands will move to this position in the line moved to 7625rather than trying to keep the same horizontal position. 7626With a non-nil argument ARG, clears out the goal column 7627so that \\[next-line] and \\[previous-line] resume vertical motion. 7628The goal column is stored in the variable `goal-column'. 7629This is a buffer-local setting." 7630 (interactive "P") 7631 (if arg 7632 (progn 7633 (setq goal-column nil) 7634 (message "No goal column")) 7635 (setq goal-column (current-column)) 7636 ;; The older method below can be erroneous if `set-goal-column' is bound 7637 ;; to a sequence containing % 7638 ;;(message (substitute-command-keys 7639 ;;"Goal column %d (use \\[set-goal-column] with an arg to unset it)") 7640 ;;goal-column) 7641 (message "%s" 7642 (concat 7643 (format "Goal column %d " goal-column) 7644 (substitute-command-keys 7645 "(use \\[set-goal-column] with an arg to unset it)"))) 7646 7647 ) 7648 nil) 7649 7650;;; Editing based on visual lines, as opposed to logical lines. 7651 7652(defun end-of-visual-line (&optional n) 7653 "Move point to end of current visual line. 7654With argument N not nil or 1, move forward N - 1 visual lines first. 7655If point reaches the beginning or end of buffer, it stops there. 7656To ignore intangibility, bind `inhibit-point-motion-hooks' to t." 7657 (interactive "^p") 7658 (or n (setq n 1)) 7659 (if (/= n 1) 7660 (let ((line-move-visual t)) 7661 (line-move (1- n) t))) 7662 ;; Unlike `move-beginning-of-line', `move-end-of-line' doesn't 7663 ;; constrain to field boundaries, so we don't either. 7664 (vertical-motion (cons (window-width) 0))) 7665 7666(defun beginning-of-visual-line (&optional n) 7667 "Move point to beginning of current visual line. 7668With argument N not nil or 1, move forward N - 1 visual lines first. 7669If point reaches the beginning or end of buffer, it stops there. 7670\(But if the buffer doesn't end in a newline, it stops at the 7671beginning of the last visual line.) 7672To ignore intangibility, bind `inhibit-point-motion-hooks' to t." 7673 (interactive "^p") 7674 (or n (setq n 1)) 7675 (let ((opoint (point))) 7676 (if (/= n 1) 7677 (let ((line-move-visual t)) 7678 (line-move (1- n) t))) 7679 (vertical-motion 0) 7680 ;; Constrain to field boundaries, like `move-beginning-of-line'. 7681 (goto-char (constrain-to-field (point) opoint (/= n 1))))) 7682 7683(defun kill-visual-line (&optional arg) 7684 "Kill the rest of the visual line. 7685With prefix argument ARG, kill that many visual lines from point. 7686If ARG is negative, kill visual lines backward. 7687If ARG is zero, kill the text before point on the current visual 7688line. 7689 7690If the variable `kill-whole-line' is non-nil, and this command is 7691invoked at start of a line that ends in a newline, kill the newline 7692as well. 7693 7694If you want to append the killed line to the last killed text, 7695use \\[append-next-kill] before \\[kill-line]. 7696 7697If the buffer is read-only, Emacs will beep and refrain from deleting 7698the line, but put the line in the kill ring anyway. This means that 7699you can use this command to copy text from a read-only buffer. 7700\(If the variable `kill-read-only-ok' is non-nil, then this won't 7701even beep.)" 7702 (interactive "P") 7703 ;; Like in `kill-line', it's better to move point to the other end 7704 ;; of the kill before killing. 7705 (let ((opoint (point)) 7706 (kill-whole-line (and kill-whole-line (bolp))) 7707 (orig-vlnum (cdr (nth 6 (posn-at-point))))) 7708 (if arg 7709 (vertical-motion (prefix-numeric-value arg)) 7710 (end-of-visual-line 1) 7711 (if (= (point) opoint) 7712 (vertical-motion 1) 7713 ;; The first condition below verifies we are still on the same 7714 ;; screen line, i.e. that the line isn't continued, and that 7715 ;; end-of-visual-line didn't overshoot due to complications 7716 ;; like display or overlay strings, intangible text, etc.: 7717 ;; otherwise, we don't want to kill a character that's 7718 ;; unrelated to the place where the visual line wraps. 7719 (and (= (cdr (nth 6 (posn-at-point))) orig-vlnum) 7720 ;; Make sure we delete the character where the line wraps 7721 ;; under visual-line-mode, be it whitespace or a 7722 ;; character whose category set allows to wrap at it. 7723 (or (looking-at-p "[ \t]") 7724 (and word-wrap-by-category 7725 (aref (char-category-set (following-char)) ?\|))) 7726 (forward-char)))) 7727 (kill-region opoint (if (and kill-whole-line (= (following-char) ?\n)) 7728 (1+ (point)) 7729 (point))))) 7730 7731(defun next-logical-line (&optional arg try-vscroll) 7732 "Move cursor vertically down ARG lines. 7733This is identical to `next-line', except that it always moves 7734by logical lines instead of visual lines, ignoring the value of 7735the variable `line-move-visual'." 7736 (interactive "^p\np") 7737 (let ((line-move-visual nil)) 7738 (with-no-warnings 7739 (next-line arg try-vscroll)))) 7740 7741(defun previous-logical-line (&optional arg try-vscroll) 7742 "Move cursor vertically up ARG lines. 7743This is identical to `previous-line', except that it always moves 7744by logical lines instead of visual lines, ignoring the value of 7745the variable `line-move-visual'." 7746 (interactive "^p\np") 7747 (let ((line-move-visual nil)) 7748 (with-no-warnings 7749 (previous-line arg try-vscroll)))) 7750 7751(defgroup visual-line nil 7752 "Editing based on visual lines." 7753 :group 'convenience 7754 :version "23.1") 7755 7756(defvar visual-line-mode-map 7757 (let ((map (make-sparse-keymap))) 7758 (define-key map [remap kill-line] 'kill-visual-line) 7759 (define-key map [remap move-beginning-of-line] 'beginning-of-visual-line) 7760 (define-key map [remap move-end-of-line] 'end-of-visual-line) 7761 ;; These keybindings interfere with xterm function keys. Are 7762 ;; there any other suitable bindings? 7763 ;; (define-key map "\M-[" 'previous-logical-line) 7764 ;; (define-key map "\M-]" 'next-logical-line) 7765 map)) 7766 7767(defcustom visual-line-fringe-indicators '(nil nil) 7768 "How fringe indicators are shown for wrapped lines in `visual-line-mode'. 7769The value should be a list of the form (LEFT RIGHT), where LEFT 7770and RIGHT are symbols representing the bitmaps to display, to 7771indicate wrapped lines, in the left and right fringes respectively. 7772See also `fringe-indicator-alist'. 7773The default is not to display fringe indicators for wrapped lines. 7774This variable does not affect fringe indicators displayed for 7775other purposes." 7776 :type '(list (choice (const :tag "Hide left indicator" nil) 7777 (const :tag "Left curly arrow" left-curly-arrow) 7778 (symbol :tag "Other bitmap")) 7779 (choice (const :tag "Hide right indicator" nil) 7780 (const :tag "Right curly arrow" right-curly-arrow) 7781 (symbol :tag "Other bitmap"))) 7782 :set (lambda (symbol value) 7783 (dolist (buf (buffer-list)) 7784 (with-current-buffer buf 7785 (when (and (boundp 'visual-line-mode) 7786 (symbol-value 'visual-line-mode)) 7787 (setq fringe-indicator-alist 7788 (cons (cons 'continuation value) 7789 (assq-delete-all 7790 'continuation 7791 (copy-tree fringe-indicator-alist))))))) 7792 (set-default symbol value))) 7793 7794(defvar visual-line--saved-state nil) 7795 7796(define-minor-mode visual-line-mode 7797 "Toggle visual line based editing (Visual Line mode) in the current buffer. 7798 7799When Visual Line mode is enabled, `word-wrap' is turned on in 7800this buffer, and simple editing commands are redefined to act on 7801visual lines, not logical lines. See Info node `Visual Line 7802Mode' for details. 7803Turning on this mode disables line truncation set up by 7804variables `truncate-lines' and `truncate-partial-width-windows'." 7805 :keymap visual-line-mode-map 7806 :group 'visual-line 7807 :lighter " Wrap" 7808 (if visual-line-mode 7809 (progn 7810 (unless visual-line--saved-state 7811 (setq-local visual-line--saved-state (list nil)) 7812 ;; Save the local values of some variables, to be restored if 7813 ;; visual-line-mode is turned off. 7814 (dolist (var '(line-move-visual truncate-lines 7815 truncate-partial-width-windows 7816 word-wrap fringe-indicator-alist)) 7817 (if (local-variable-p var) 7818 (push (cons var (symbol-value var)) 7819 visual-line--saved-state)))) 7820 (setq-local line-move-visual t) 7821 (setq-local truncate-partial-width-windows nil) 7822 (setq truncate-lines nil 7823 word-wrap t 7824 fringe-indicator-alist 7825 (cons (cons 'continuation visual-line-fringe-indicators) 7826 fringe-indicator-alist))) 7827 (kill-local-variable 'line-move-visual) 7828 (kill-local-variable 'word-wrap) 7829 (kill-local-variable 'truncate-lines) 7830 (kill-local-variable 'truncate-partial-width-windows) 7831 (kill-local-variable 'fringe-indicator-alist) 7832 (dolist (saved visual-line--saved-state) 7833 (when (car saved) 7834 (set (make-local-variable (car saved)) (cdr saved)))) 7835 (kill-local-variable 'visual-line--saved-state))) 7836 7837(defun turn-on-visual-line-mode () 7838 (visual-line-mode 1)) 7839 7840(define-globalized-minor-mode global-visual-line-mode 7841 visual-line-mode turn-on-visual-line-mode) 7842 7843 7844(defun transpose-chars (arg) 7845 "Interchange characters around point, moving forward one character. 7846With prefix arg ARG, effect is to take character before point 7847and drag it forward past ARG other characters (backward if ARG negative). 7848If no argument and at end of line, the previous two chars are exchanged." 7849 (interactive "*P") 7850 (when (and (null arg) (eolp) (not (bobp)) 7851 (not (get-text-property (1- (point)) 'read-only))) 7852 (forward-char -1)) 7853 (transpose-subr 'forward-char (prefix-numeric-value arg))) 7854 7855(defun transpose-words (arg) 7856 "Interchange words around point, leaving point at end of them. 7857With prefix arg ARG, effect is to take word before or around point 7858and drag it forward past ARG other words (backward if ARG negative). 7859If ARG is zero, the words around or after point and around or after mark 7860are interchanged." 7861 ;; FIXME: `foo a!nd bar' should transpose into `bar and foo'. 7862 (interactive "*p") 7863 (transpose-subr 'forward-word arg)) 7864 7865(defun transpose-sexps (arg &optional interactive) 7866 "Like \\[transpose-chars] (`transpose-chars'), but applies to sexps. 7867Unlike `transpose-words', point must be between the two sexps and not 7868in the middle of a sexp to be transposed. 7869With non-zero prefix arg ARG, effect is to take the sexp before point 7870and drag it forward past ARG other sexps (backward if ARG is negative). 7871If ARG is zero, the sexps ending at or after point and at or after mark 7872are interchanged. 7873If INTERACTIVE is non-nil, as it is interactively, 7874report errors as appropriate for this kind of usage." 7875 (interactive "*p\nd") 7876 (if interactive 7877 (condition-case nil 7878 (transpose-sexps arg nil) 7879 (scan-error (user-error "Not between two complete sexps"))) 7880 (transpose-subr 7881 (lambda (arg) 7882 ;; Here we should try to simulate the behavior of 7883 ;; (cons (progn (forward-sexp x) (point)) 7884 ;; (progn (forward-sexp (- x)) (point))) 7885 ;; Except that we don't want to rely on the second forward-sexp 7886 ;; putting us back to where we want to be, since forward-sexp-function 7887 ;; might do funny things like infix-precedence. 7888 (if (if (> arg 0) 7889 (looking-at "\\sw\\|\\s_") 7890 (and (not (bobp)) 7891 (save-excursion 7892 (forward-char -1) 7893 (looking-at "\\sw\\|\\s_")))) 7894 ;; Jumping over a symbol. We might be inside it, mind you. 7895 (progn (funcall (if (> arg 0) 7896 'skip-syntax-backward 'skip-syntax-forward) 7897 "w_") 7898 (cons (save-excursion (forward-sexp arg) (point)) (point))) 7899 ;; Otherwise, we're between sexps. Take a step back before jumping 7900 ;; to make sure we'll obey the same precedence no matter which 7901 ;; direction we're going. 7902 (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) 7903 " .") 7904 (cons (save-excursion (forward-sexp arg) (point)) 7905 (progn (while (or (forward-comment (if (> arg 0) 1 -1)) 7906 (not (zerop (funcall (if (> arg 0) 7907 'skip-syntax-forward 7908 'skip-syntax-backward) 7909 "."))))) 7910 (point))))) 7911 arg 'special))) 7912 7913(defun transpose-lines (arg) 7914 "Exchange current line and previous line, leaving point after both. 7915With argument ARG, takes previous line and moves it past ARG lines. 7916With argument 0, interchanges line point is in with line mark is in." 7917 (interactive "*p") 7918 (transpose-subr (lambda (arg) 7919 (if (> arg 0) 7920 (progn 7921 ;; Move forward over ARG lines, 7922 ;; but create newlines if necessary. 7923 (setq arg (forward-line arg)) 7924 (if (/= (preceding-char) ?\n) 7925 (setq arg (1+ arg))) 7926 (if (> arg 0) 7927 (newline arg))) 7928 (forward-line arg))) 7929 arg)) 7930 7931;; FIXME seems to leave point BEFORE the current object when ARG = 0, 7932;; which seems inconsistent with the ARG /= 0 case. 7933;; FIXME document SPECIAL. 7934(defun transpose-subr (mover arg &optional special) 7935 "Subroutine to do the work of transposing objects. 7936Works for lines, sentences, paragraphs, etc. MOVER is a function that 7937moves forward by units of the given object (e.g. `forward-sentence', 7938`forward-paragraph'). If ARG is zero, exchanges the current object 7939with the one containing mark. If ARG is an integer, moves the 7940current object past ARG following (if ARG is positive) or 7941preceding (if ARG is negative) objects, leaving point after the 7942current object." 7943 (let ((aux (if special mover 7944 (lambda (x) 7945 (cons (progn (funcall mover x) (point)) 7946 (progn (funcall mover (- x)) (point)))))) 7947 pos1 pos2) 7948 (cond 7949 ((= arg 0) 7950 (save-excursion 7951 (setq pos1 (funcall aux 1)) 7952 (goto-char (or (mark) (error "No mark set in this buffer"))) 7953 (setq pos2 (funcall aux 1)) 7954 (transpose-subr-1 pos1 pos2)) 7955 (exchange-point-and-mark)) 7956 ((> arg 0) 7957 (setq pos1 (funcall aux -1)) 7958 (setq pos2 (funcall aux arg)) 7959 (transpose-subr-1 pos1 pos2) 7960 (goto-char (car pos2))) 7961 (t 7962 (setq pos1 (funcall aux -1)) 7963 (goto-char (car pos1)) 7964 (setq pos2 (funcall aux arg)) 7965 (transpose-subr-1 pos1 pos2) 7966 (goto-char (+ (car pos2) (- (cdr pos1) (car pos1)))))))) 7967 7968(defun transpose-subr-1 (pos1 pos2) 7969 (when (> (car pos1) (cdr pos1)) (setq pos1 (cons (cdr pos1) (car pos1)))) 7970 (when (> (car pos2) (cdr pos2)) (setq pos2 (cons (cdr pos2) (car pos2)))) 7971 (when (> (car pos1) (car pos2)) 7972 (let ((swap pos1)) 7973 (setq pos1 pos2 pos2 swap))) 7974 (if (> (cdr pos1) (car pos2)) (error "Don't have two things to transpose")) 7975 (atomic-change-group 7976 ;; This sequence of insertions attempts to preserve marker 7977 ;; positions at the start and end of the transposed objects. 7978 (let* ((word (buffer-substring (car pos2) (cdr pos2))) 7979 (len1 (- (cdr pos1) (car pos1))) 7980 (len2 (length word)) 7981 (boundary (make-marker))) 7982 (set-marker boundary (car pos2)) 7983 (goto-char (cdr pos1)) 7984 (insert-before-markers word) 7985 (setq word (delete-and-extract-region (car pos1) (+ (car pos1) len1))) 7986 (goto-char boundary) 7987 (insert word) 7988 (goto-char (+ boundary len1)) 7989 (delete-region (point) (+ (point) len2)) 7990 (set-marker boundary nil)))) 7991 7992(defun backward-word (&optional arg) 7993 "Move backward until encountering the beginning of a word. 7994With argument ARG, do this that many times. 7995If ARG is omitted or nil, move point backward one word. 7996 7997The word boundaries are normally determined by the buffer's 7998syntax table and character script (according to 7999`char-script-table'), but `find-word-boundary-function-table', 8000such as set up by `subword-mode', can change that. If a Lisp 8001program needs to move by words determined strictly by the syntax 8002table, it should use `backward-word-strictly' instead. See Info 8003node `(elisp) Word Motion' for details." 8004 (interactive "^p") 8005 (forward-word (- (or arg 1)))) 8006 8007(defun mark-word (&optional arg allow-extend) 8008 "Set mark ARG words away from point. 8009The place mark goes is the same place \\[forward-word] would 8010move to with the same argument. 8011Interactively, if this command is repeated 8012or (in Transient Mark mode) if the mark is active, 8013it marks the next ARG words after the ones already marked." 8014 (interactive "P\np") 8015 (cond ((and allow-extend 8016 (or (and (eq last-command this-command) (mark t)) 8017 (region-active-p))) 8018 (setq arg (if arg (prefix-numeric-value arg) 8019 (if (< (mark) (point)) -1 1))) 8020 (set-mark 8021 (save-excursion 8022 (goto-char (mark)) 8023 (forward-word arg) 8024 (point)))) 8025 (t 8026 (push-mark 8027 (save-excursion 8028 (forward-word (prefix-numeric-value arg)) 8029 (point)) 8030 nil t)))) 8031 8032(defun kill-word (arg) 8033 "Kill characters forward until encountering the end of a word. 8034With argument ARG, do this that many times." 8035 (interactive "p") 8036 (kill-region (point) (progn (forward-word arg) (point)))) 8037 8038(defun backward-kill-word (arg) 8039 "Kill characters backward until encountering the beginning of a word. 8040With argument ARG, do this that many times." 8041 (interactive "p") 8042 (kill-word (- arg))) 8043 8044(defun current-word (&optional strict really-word) 8045 "Return the word at or near point, as a string. 8046The return value includes no text properties. 8047 8048If optional arg STRICT is non-nil, return nil unless point is 8049within or adjacent to a word, otherwise look for a word within 8050point's line. If there is no word anywhere on point's line, the 8051value is nil regardless of STRICT. 8052 8053By default, this function treats as a single word any sequence of 8054characters that have either word or symbol syntax. If optional 8055arg REALLY-WORD is non-nil, only characters of word syntax can 8056constitute a word." 8057 (save-excursion 8058 (let* ((oldpoint (point)) (start (point)) (end (point)) 8059 (syntaxes (if really-word "w" "w_")) 8060 (not-syntaxes (concat "^" syntaxes))) 8061 (skip-syntax-backward syntaxes) (setq start (point)) 8062 (goto-char oldpoint) 8063 (skip-syntax-forward syntaxes) (setq end (point)) 8064 (when (and (eq start oldpoint) (eq end oldpoint) 8065 ;; Point is neither within nor adjacent to a word. 8066 (not strict)) 8067 ;; Look for preceding word in same line. 8068 (skip-syntax-backward not-syntaxes (line-beginning-position)) 8069 (if (bolp) 8070 ;; No preceding word in same line. 8071 ;; Look for following word in same line. 8072 (progn 8073 (skip-syntax-forward not-syntaxes (line-end-position)) 8074 (setq start (point)) 8075 (skip-syntax-forward syntaxes) 8076 (setq end (point))) 8077 (setq end (point)) 8078 (skip-syntax-backward syntaxes) 8079 (setq start (point)))) 8080 ;; If we found something nonempty, return it as a string. 8081 (unless (= start end) 8082 (buffer-substring-no-properties start end))))) 8083 8084(defcustom fill-prefix nil 8085 "String for filling to insert at front of new line, or nil for none." 8086 :type '(choice (const :tag "None" nil) 8087 string) 8088 :group 'fill) 8089(make-variable-buffer-local 'fill-prefix) 8090(put 'fill-prefix 'safe-local-variable 'string-or-null-p) 8091 8092(defcustom auto-fill-inhibit-regexp nil 8093 "Regexp to match lines that should not be auto-filled." 8094 :type '(choice (const :tag "None" nil) 8095 regexp) 8096 :group 'fill) 8097 8098(defun do-auto-fill () 8099 "The default value for `normal-auto-fill-function'. 8100This is the default auto-fill function, some major modes use a different one. 8101Returns t if it really did any work." 8102 (let (fc justify give-up 8103 (fill-prefix fill-prefix)) 8104 (if (or (not (setq justify (current-justification))) 8105 (null (setq fc (current-fill-column))) 8106 (and (eq justify 'left) 8107 (<= (current-column) fc)) 8108 (and auto-fill-inhibit-regexp 8109 (save-excursion (beginning-of-line) 8110 (looking-at auto-fill-inhibit-regexp)))) 8111 nil ;; Auto-filling not required 8112 (if (memq justify '(full center right)) 8113 (save-excursion (unjustify-current-line))) 8114 8115 ;; Choose a fill-prefix automatically. 8116 (when (and adaptive-fill-mode 8117 (or (null fill-prefix) (string= fill-prefix ""))) 8118 (let ((prefix 8119 (fill-context-prefix 8120 (save-excursion (fill-forward-paragraph -1) (point)) 8121 (save-excursion (fill-forward-paragraph 1) (point))))) 8122 (and prefix (not (equal prefix "")) 8123 ;; Use auto-indentation rather than a guessed empty prefix. 8124 (not (and fill-indent-according-to-mode 8125 (string-match "\\`[ \t]*\\'" prefix))) 8126 (setq fill-prefix prefix)))) 8127 8128 (while (and (not give-up) (> (current-column) fc)) 8129 ;; Determine where to split the line. 8130 (let ((fill-point 8131 (save-excursion 8132 (beginning-of-line) 8133 ;; Don't split earlier in the line than the length of the 8134 ;; fill prefix, since the resulting line would be longer. 8135 (when fill-prefix 8136 (move-to-column (string-width fill-prefix))) 8137 (let ((after-prefix (point))) 8138 (move-to-column (1+ fc)) 8139 (fill-move-to-break-point after-prefix) 8140 (point))))) 8141 8142 ;; See whether the place we found is any good. 8143 (if (save-excursion 8144 (goto-char fill-point) 8145 (or (bolp) 8146 ;; There is no use breaking at end of line. 8147 (save-excursion (skip-chars-forward " ") (eolp)) 8148 ;; Don't split right after a comment starter 8149 ;; since we would just make another comment starter. 8150 (and comment-start-skip 8151 (let ((limit (point))) 8152 (beginning-of-line) 8153 (and (re-search-forward comment-start-skip 8154 limit t) 8155 (eq (point) limit)))))) 8156 ;; No good place to break => stop trying. 8157 (setq give-up t) 8158 ;; Ok, we have a useful place to break the line. Do it. 8159 (let ((prev-column (current-column))) 8160 ;; If point is at the fill-point, do not `save-excursion'. 8161 ;; Otherwise, if a comment prefix or fill-prefix is inserted, 8162 ;; point will end up before it rather than after it. 8163 (if (save-excursion 8164 (skip-chars-backward " \t") 8165 (= (point) fill-point)) 8166 (default-indent-new-line t) 8167 (save-excursion 8168 (goto-char fill-point) 8169 (default-indent-new-line t))) 8170 ;; Now do justification, if required 8171 (if (not (eq justify 'left)) 8172 (save-excursion 8173 (end-of-line 0) 8174 (justify-current-line justify nil t))) 8175 ;; If making the new line didn't reduce the hpos of 8176 ;; the end of the line, then give up now; 8177 ;; trying again will not help. 8178 (if (>= (current-column) prev-column) 8179 (setq give-up t)))))) 8180 ;; Justify last line. 8181 (justify-current-line justify t t) 8182 t))) 8183 8184(defvar comment-line-break-function 'comment-indent-new-line 8185 "Mode-specific function that line breaks and continues a comment. 8186This function is called during auto-filling when a comment syntax 8187is defined. 8188The function should take a single optional argument, which is a flag 8189indicating whether it should use soft newlines.") 8190 8191(defun default-indent-new-line (&optional soft force) 8192 "Break line at point and indent. 8193If a comment syntax is defined, call `comment-line-break-function'. 8194 8195The inserted newline is marked hard if variable `use-hard-newlines' is true, 8196unless optional argument SOFT is non-nil." 8197 (interactive (list nil t)) 8198 (if comment-start 8199 ;; Force breaking the line when called interactively. 8200 (if force 8201 (let ((comment-auto-fill-only-comments nil)) 8202 (funcall comment-line-break-function soft)) 8203 (funcall comment-line-break-function soft)) 8204 ;; Insert the newline before removing empty space so that markers 8205 ;; get preserved better. 8206 (if soft (insert-and-inherit ?\n) (newline 1)) 8207 (save-excursion (forward-char -1) (delete-horizontal-space)) 8208 (delete-horizontal-space) 8209 8210 (if (and fill-prefix (not adaptive-fill-mode)) 8211 ;; Blindly trust a non-adaptive fill-prefix. 8212 (progn 8213 (indent-to-left-margin) 8214 (insert-before-markers-and-inherit fill-prefix)) 8215 8216 (cond 8217 ;; If there's an adaptive prefix, use it unless we're inside 8218 ;; a comment and the prefix is not a comment starter. 8219 (fill-prefix 8220 (indent-to-left-margin) 8221 (insert-and-inherit fill-prefix)) 8222 ;; If we're not inside a comment, just try to indent. 8223 (t (indent-according-to-mode)))))) 8224 8225(defun internal-auto-fill () 8226 "The function called by `self-insert-command' to perform auto-filling." 8227 (when (or (not comment-start) 8228 (not comment-auto-fill-only-comments) 8229 (nth 4 (syntax-ppss))) 8230 (funcall auto-fill-function))) 8231 8232(defvar normal-auto-fill-function 'do-auto-fill 8233 "The function to use for `auto-fill-function' if Auto Fill mode is turned on. 8234Some major modes set this.") 8235 8236(put 'auto-fill-function :minor-mode-function 'auto-fill-mode) 8237;; `functions' and `hooks' are usually unsafe to set, but setting 8238;; auto-fill-function to nil in a file-local setting is safe and 8239;; can be useful to prevent auto-filling. 8240(put 'auto-fill-function 'safe-local-variable 'null) 8241 8242(define-minor-mode auto-fill-mode 8243 "Toggle automatic line breaking (Auto Fill mode). 8244 8245When Auto Fill mode is enabled, inserting a space at a column 8246beyond `current-fill-column' automatically breaks the line at a 8247previous space. 8248 8249When `auto-fill-mode' is on, the `auto-fill-function' variable is 8250non-nil. 8251 8252The value of `normal-auto-fill-function' specifies the function to use 8253for `auto-fill-function' when turning Auto Fill mode on." 8254 :variable (auto-fill-function 8255 . (lambda (v) (setq auto-fill-function 8256 (if v normal-auto-fill-function))))) 8257 8258;; This holds a document string used to document auto-fill-mode. 8259(defun auto-fill-function () 8260 "Automatically break line at a previous space, in insertion of text." 8261 nil) 8262 8263(defun turn-on-auto-fill () 8264 "Unconditionally turn on Auto Fill mode." 8265 (auto-fill-mode 1)) 8266 8267(defun turn-off-auto-fill () 8268 "Unconditionally turn off Auto Fill mode." 8269 (auto-fill-mode -1)) 8270 8271(custom-add-option 'text-mode-hook 'turn-on-auto-fill) 8272 8273(defun set-fill-column (arg) 8274 "Set `fill-column' to specified argument. 8275Use \\[universal-argument] followed by a number to specify a column. 8276Just \\[universal-argument] as argument means to use the current column." 8277 (interactive 8278 (list (or current-prefix-arg 8279 ;; We used to use current-column silently, but C-x f is too easily 8280 ;; typed as a typo for C-x C-f, so we turned it into an error and 8281 ;; now an interactive prompt. 8282 (read-number "Set fill-column to: " (current-column))))) 8283 (if (consp arg) 8284 (setq arg (current-column))) 8285 (if (not (integerp arg)) 8286 ;; Disallow missing argument; it's probably a typo for C-x C-f. 8287 (error "set-fill-column requires an explicit argument") 8288 (message "Fill column set to %d (was %d)" arg fill-column) 8289 (setq fill-column arg))) 8290 8291(defun set-selective-display (arg) 8292 "Set `selective-display' to ARG; clear it if no arg. 8293When the value of `selective-display' is a number > 0, 8294lines whose indentation is >= that value are not displayed. 8295The variable `selective-display' has a separate value for each buffer." 8296 (interactive "P") 8297 (if (eq selective-display t) 8298 (error "selective-display already in use for marked lines")) 8299 (let ((current-vpos 8300 (save-restriction 8301 (narrow-to-region (point-min) (point)) 8302 (goto-char (window-start)) 8303 (vertical-motion (window-height))))) 8304 (setq selective-display 8305 (and arg (prefix-numeric-value arg))) 8306 (recenter current-vpos)) 8307 (set-window-start (selected-window) (window-start)) 8308 (princ "selective-display set to " t) 8309 (prin1 selective-display t) 8310 (princ "." t)) 8311 8312(defvaralias 'indicate-unused-lines 'indicate-empty-lines) 8313 8314(defun toggle-truncate-lines (&optional arg) 8315 "Toggle truncating of long lines for the current buffer. 8316When truncating is off, long lines are folded. 8317With prefix argument ARG, truncate long lines if ARG is positive, 8318otherwise fold them. Note that in side-by-side windows, this 8319command has no effect if `truncate-partial-width-windows' is 8320non-nil." 8321 (interactive "P") 8322 (setq truncate-lines 8323 (if (null arg) 8324 (not truncate-lines) 8325 (> (prefix-numeric-value arg) 0))) 8326 (force-mode-line-update) 8327 (unless truncate-lines 8328 (let ((buffer (current-buffer))) 8329 (walk-windows (lambda (window) 8330 (if (eq buffer (window-buffer window)) 8331 (set-window-hscroll window 0))) 8332 nil t))) 8333 (message "Truncate long lines %s%s" 8334 (if truncate-lines "enabled" "disabled") 8335 (if (and truncate-lines visual-line-mode) 8336 (progn 8337 (visual-line-mode -1) 8338 (format-message " and `visual-line-mode' disabled")) 8339 ""))) 8340 8341(defun toggle-word-wrap (&optional arg) 8342 "Toggle whether to use word-wrapping for continuation lines. 8343With prefix argument ARG, wrap continuation lines at word boundaries 8344if ARG is positive, otherwise wrap them at the right screen edge. 8345This command toggles the value of `word-wrap'. It has no effect 8346if long lines are truncated." 8347 (interactive "P") 8348 (setq word-wrap 8349 (if (null arg) 8350 (not word-wrap) 8351 (> (prefix-numeric-value arg) 0))) 8352 (force-mode-line-update) 8353 (message "Word wrapping %s" 8354 (if word-wrap "enabled" "disabled"))) 8355 8356(defvar overwrite-mode-textual (purecopy " Ovwrt") 8357 "The string displayed in the mode line when in overwrite mode.") 8358(defvar overwrite-mode-binary (purecopy " Bin Ovwrt") 8359 "The string displayed in the mode line when in binary overwrite mode.") 8360 8361(define-minor-mode overwrite-mode 8362 "Toggle Overwrite mode. 8363 8364When Overwrite mode is enabled, printing characters typed in 8365replace existing text on a one-for-one basis, rather than pushing 8366it to the right. At the end of a line, such characters extend 8367the line. Before a tab, such characters insert until the tab is 8368filled in. \\[quoted-insert] still inserts characters in 8369overwrite mode; this is supposed to make it easier to insert 8370characters when necessary." 8371 :variable (overwrite-mode 8372 . (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-textual))))) 8373 8374(define-minor-mode binary-overwrite-mode 8375 "Toggle Binary Overwrite mode. 8376 8377When Binary Overwrite mode is enabled, printing characters typed 8378in replace existing text. Newlines are not treated specially, so 8379typing at the end of a line joins the line to the next, with the 8380typed character between them. Typing before a tab character 8381simply replaces the tab with the character typed. 8382\\[quoted-insert] replaces the text at the cursor, just as 8383ordinary typing characters do. 8384 8385Note that Binary Overwrite mode is not its own minor mode; it is 8386a specialization of overwrite mode, entered by setting the 8387`overwrite-mode' variable to `overwrite-mode-binary'." 8388 :variable (overwrite-mode 8389 . (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-binary))))) 8390 8391(define-minor-mode line-number-mode 8392 "Toggle line number display in the mode line (Line Number mode). 8393 8394Line numbers do not appear for very large buffers and buffers 8395with very long lines; see variables `line-number-display-limit' 8396and `line-number-display-limit-width'. 8397 8398See `mode-line-position-line-format' for how this number is 8399presented." 8400 :init-value t :global t :group 'mode-line) 8401 8402(define-minor-mode column-number-mode 8403 "Toggle column number display in the mode line (Column Number mode). 8404 8405See `mode-line-position-column-format' for how this number is 8406presented." 8407 :global t :group 'mode-line) 8408 8409(define-minor-mode size-indication-mode 8410 "Toggle buffer size display in the mode line (Size Indication mode)." 8411 :global t :group 'mode-line) 8412 8413(define-minor-mode auto-save-mode 8414 "Toggle auto-saving in the current buffer (Auto Save mode)." 8415 :variable ((and buffer-auto-save-file-name 8416 ;; If auto-save is off because buffer has shrunk, 8417 ;; then toggling should turn it on. 8418 (>= buffer-saved-size 0)) 8419 . (lambda (val) 8420 (setq buffer-auto-save-file-name 8421 (cond 8422 ((null val) nil) 8423 ((and buffer-file-name auto-save-visited-file-name 8424 (not buffer-read-only)) 8425 buffer-file-name) 8426 (t (make-auto-save-file-name)))))) 8427 ;; If -1 was stored here, to temporarily turn off saving, 8428 ;; turn it back on. 8429 (and (< buffer-saved-size 0) 8430 (setq buffer-saved-size 0))) 8431 8432(defgroup paren-blinking nil 8433 "Blinking matching of parens and expressions." 8434 :prefix "blink-matching-" 8435 :group 'paren-matching) 8436 8437(defcustom blink-matching-paren t 8438 "Non-nil means show matching open-paren when close-paren is inserted. 8439If this is non-nil, then when you type a closing delimiter, such as a 8440closing parenthesis or brace, Emacs briefly indicates the location 8441of the matching opening delimiter. 8442 8443The valid values are: 8444 8445 t Highlight the matching open-paren if it is visible 8446 in the window, otherwise show the text with matching 8447 open-paren in the echo area. This is the default. 8448 `jump' If the matching open-paren is visible in the window, 8449 briefly move cursor to its position; otherwise show 8450 the text with matching open-paren in the echo area. 8451 `jump-offscreen' Briefly move cursor to the matching open-paren 8452 even if it is not visible in the window. 8453 nil Don't show the matching open-paren. 8454 8455Any other non-nil value is handled the same as t." 8456 8457 :type '(choice 8458 (const :tag "Disable" nil) 8459 (const :tag "Highlight open-paren if visible" t) 8460 (const :tag "Move cursor to open-paren if visible" jump) 8461 (const :tag "Move cursor even if it's off screen" jump-offscreen)) 8462 :group 'paren-blinking) 8463 8464(defcustom blink-matching-paren-on-screen t 8465 "Non-nil means show matching open-paren when it is on screen. 8466If nil, don't show it (but the open-paren can still be shown 8467in the echo area when it is off screen). 8468 8469This variable has no effect if `blink-matching-paren' is nil. 8470\(In that case, the open-paren is never shown.) 8471It is also ignored if `show-paren-mode' is enabled." 8472 :type 'boolean 8473 :group 'paren-blinking) 8474 8475(defcustom blink-matching-paren-distance (* 100 1024) 8476 "If non-nil, maximum distance to search backwards for matching open-paren. 8477If nil, search stops at the beginning of the accessible portion of the buffer." 8478 :version "23.2" ; 25->100k 8479 :type '(choice (const nil) integer) 8480 :group 'paren-blinking) 8481 8482(defcustom blink-matching-delay 1 8483 "Time in seconds to delay after showing a matching paren." 8484 :type 'number 8485 :group 'paren-blinking) 8486 8487(defcustom blink-matching-paren-dont-ignore-comments nil 8488 "If nil, `blink-matching-paren' ignores comments. 8489More precisely, when looking for the matching parenthesis, 8490it skips the contents of comments that end before point." 8491 :type 'boolean 8492 :group 'paren-blinking) 8493 8494(defun blink-matching-check-mismatch (start end) 8495 "Return whether or not START...END are matching parens. 8496END is the current point and START is the blink position. 8497START might be nil if no matching starter was found. 8498Returns non-nil if we find there is a mismatch." 8499 (let* ((end-syntax (syntax-after (1- end))) 8500 (matching-paren (and (consp end-syntax) 8501 (eq (syntax-class end-syntax) 5) 8502 (cdr end-syntax)))) 8503 ;; For self-matched chars like " and $, we can't know when they're 8504 ;; mismatched or unmatched, so we can do it only for parens. 8505 (when matching-paren 8506 (not (and start 8507 (or 8508 (eq (char-after start) matching-paren) 8509 ;; The cdr might hold a new paren-class info rather than 8510 ;; a matching-char info, in which case the two CDRs 8511 ;; should match. 8512 (eq matching-paren (cdr-safe (syntax-after start))))))))) 8513 8514(defvar blink-matching-check-function #'blink-matching-check-mismatch 8515 "Function to check parentheses mismatches. 8516The function takes two arguments (START and END) where START is the 8517position just before the opening token and END is the position right after. 8518START can be nil, if it was not found. 8519The function should return non-nil if the two tokens do not match.") 8520 8521(defvar blink-matching--overlay 8522 (let ((ol (make-overlay (point) (point) nil t))) 8523 (overlay-put ol 'face 'show-paren-match) 8524 (delete-overlay ol) 8525 ol) 8526 "Overlay used to highlight the matching paren.") 8527 8528(defun blink-matching-open () 8529 "Momentarily highlight the beginning of the sexp before point." 8530 (interactive) 8531 (when (and (not (bobp)) 8532 blink-matching-paren) 8533 (let* ((oldpos (point)) 8534 (message-log-max nil) ; Don't log messages about paren matching. 8535 (blinkpos 8536 (save-excursion 8537 (save-restriction 8538 (syntax-propertize (point)) 8539 (if blink-matching-paren-distance 8540 (narrow-to-region 8541 (max (minibuffer-prompt-end) ;(point-min) unless minibuf. 8542 (- (point) blink-matching-paren-distance)) 8543 oldpos)) 8544 (let ((parse-sexp-ignore-comments 8545 (and parse-sexp-ignore-comments 8546 (not blink-matching-paren-dont-ignore-comments)))) 8547 (condition-case () 8548 (progn 8549 (forward-sexp -1) 8550 ;; backward-sexp skips backward over prefix chars, 8551 ;; so move back to the matching paren. 8552 (while (and (< (point) (1- oldpos)) 8553 (let ((code (syntax-after (point)))) 8554 (or (eq (syntax-class code) 6) 8555 (eq (logand 1048576 (car code)) 8556 1048576)))) 8557 (forward-char 1)) 8558 (point)) 8559 (error nil)))))) 8560 (mismatch (funcall blink-matching-check-function blinkpos oldpos))) 8561 (cond 8562 (mismatch 8563 (if blinkpos 8564 (if (minibufferp) 8565 (minibuffer-message "Mismatched parentheses") 8566 (message "Mismatched parentheses")) 8567 (if (minibufferp) 8568 (minibuffer-message "No matching parenthesis found") 8569 (message "No matching parenthesis found")))) 8570 ((not blinkpos) nil) 8571 ((or 8572 (eq blink-matching-paren 'jump-offscreen) 8573 (pos-visible-in-window-p blinkpos)) 8574 ;; Matching open within window, temporarily move to or highlight 8575 ;; char after blinkpos but only if `blink-matching-paren-on-screen' 8576 ;; is non-nil. 8577 (and blink-matching-paren-on-screen 8578 (not show-paren-mode) 8579 (if (memq blink-matching-paren '(jump jump-offscreen)) 8580 (save-excursion 8581 (goto-char blinkpos) 8582 (sit-for blink-matching-delay)) 8583 (unwind-protect 8584 (progn 8585 (move-overlay blink-matching--overlay blinkpos (1+ blinkpos) 8586 (current-buffer)) 8587 (sit-for blink-matching-delay)) 8588 (delete-overlay blink-matching--overlay))))) 8589 ((not show-paren-context-when-offscreen) 8590 (minibuffer-message 8591 "Matches %s" 8592 (substring-no-properties 8593 (blink-paren-open-paren-line-string blinkpos)))))))) 8594 8595(defun blink-paren-open-paren-line-string (pos) 8596 "Return the line string that contains the openparen at POS." 8597 (save-excursion 8598 (goto-char pos) 8599 ;; Show what precedes the open in its line, if anything. 8600 (cond 8601 ((save-excursion (skip-chars-backward " \t") (not (bolp))) 8602 (buffer-substring (line-beginning-position) 8603 (1+ pos))) 8604 ;; Show what follows the open in its line, if anything. 8605 ((save-excursion 8606 (forward-char 1) 8607 (skip-chars-forward " \t") 8608 (not (eolp))) 8609 (buffer-substring pos 8610 (line-end-position))) 8611 ;; Otherwise show the previous nonblank line, 8612 ;; if there is one. 8613 ((save-excursion (skip-chars-backward "\n \t") (not (bobp))) 8614 (concat 8615 (buffer-substring (progn 8616 (skip-chars-backward "\n \t") 8617 (line-beginning-position)) 8618 (progn (end-of-line) 8619 (skip-chars-backward " \t") 8620 (point))) 8621 ;; Replace the newline and other whitespace with `...'. 8622 "..." 8623 (buffer-substring pos (1+ pos)))) 8624 ;; There is nothing to show except the char itself. 8625 (t (buffer-substring pos (1+ pos)))))) 8626 8627(defvar blink-paren-function 'blink-matching-open 8628 "Function called, if non-nil, whenever a close parenthesis is inserted. 8629More precisely, a char with closeparen syntax is self-inserted.") 8630 8631(defun blink-paren-post-self-insert-function () 8632 (when (and (eq (char-before) last-command-event) ; Sanity check. 8633 (memq (char-syntax last-command-event) '(?\) ?\$)) 8634 blink-paren-function 8635 (not executing-kbd-macro) 8636 (not noninteractive) 8637 ;; Verify an even number of quoting characters precede the close. 8638 ;; FIXME: Also check if this parenthesis closes a comment as 8639 ;; can happen in Pascal and SML. 8640 (= 1 (logand 1 (- (point) 8641 (save-excursion 8642 (forward-char -1) 8643 (skip-syntax-backward "/\\") 8644 (point)))))) 8645 (funcall blink-paren-function))) 8646 8647(put 'blink-paren-post-self-insert-function 'priority 100) 8648 8649(add-hook 'post-self-insert-hook #'blink-paren-post-self-insert-function 8650 ;; Most likely, this hook is nil, so this arg doesn't matter, 8651 ;; but I use it as a reminder that this function usually 8652 ;; likes to be run after others since it does 8653 ;; `sit-for'. That's also the reason it get a `priority' prop 8654 ;; of 100. 8655 'append) 8656 8657;; This executes C-g typed while Emacs is waiting for a command. 8658;; Quitting out of a program does not go through here; 8659;; that happens in the maybe_quit function at the C code level. 8660(defun keyboard-quit () 8661 "Signal a `quit' condition. 8662During execution of Lisp code, this character causes a quit directly. 8663At top-level, as an editor command, this simply beeps." 8664 (interactive) 8665 ;; Avoid adding the region to the window selection. 8666 (setq saved-region-selection nil) 8667 (let (select-active-regions) 8668 (deactivate-mark)) 8669 (if (fboundp 'kmacro-keyboard-quit) 8670 (kmacro-keyboard-quit)) 8671 (when completion-in-region-mode 8672 (completion-in-region-mode -1)) 8673 ;; Force the next redisplay cycle to remove the "Def" indicator from 8674 ;; all the mode lines. 8675 (if defining-kbd-macro 8676 (force-mode-line-update t)) 8677 (setq defining-kbd-macro nil) 8678 (let ((debug-on-quit nil)) 8679 (signal 'quit nil))) 8680 8681(defvar buffer-quit-function nil 8682 "Function to call to \"quit\" the current buffer, or nil if none. 8683\\[keyboard-escape-quit] calls this function when its more local actions 8684\(such as canceling a prefix argument, minibuffer or region) do not apply.") 8685 8686(defun keyboard-escape-quit () 8687 "Exit the current \"mode\" (in a generalized sense of the word). 8688This command can exit an interactive command such as `query-replace', 8689can clear out a prefix argument or a region, 8690can get out of the minibuffer or other recursive edit, 8691cancel the use of the current buffer (for special-purpose buffers), 8692or go back to just one window (by deleting all but the selected window)." 8693 (interactive) 8694 (cond ((eq last-command 'mode-exited) nil) 8695 ((region-active-p) 8696 (deactivate-mark)) 8697 ((> (minibuffer-depth) 0) 8698 (abort-recursive-edit)) 8699 (current-prefix-arg 8700 nil) 8701 ((> (recursion-depth) 0) 8702 (exit-recursive-edit)) 8703 (buffer-quit-function 8704 (funcall buffer-quit-function)) 8705 ((not (one-window-p t)) 8706 (delete-other-windows)) 8707 ((string-match "^ \\*" (buffer-name (current-buffer))) 8708 (bury-buffer)))) 8709 8710(defun play-sound-file (file &optional volume device) 8711 "Play sound stored in FILE. 8712VOLUME and DEVICE correspond to the keywords of the sound 8713specification for `play-sound'." 8714 (interactive "fPlay sound file: ") 8715 (let ((sound (list :file file))) 8716 (if volume 8717 (plist-put sound :volume volume)) 8718 (if device 8719 (plist-put sound :device device)) 8720 (push 'sound sound) 8721 (play-sound sound))) 8722 8723 8724(defcustom read-mail-command 'rmail 8725 "Your preference for a mail reading package. 8726This is used by some keybindings that support reading mail. 8727See also `mail-user-agent' concerning sending mail." 8728 :type '(radio (function-item :tag "Rmail" :format "%t\n" rmail) 8729 (function-item :tag "Gnus" :format "%t\n" gnus) 8730 (function-item :tag "Emacs interface to MH" 8731 :format "%t\n" mh-rmail) 8732 (function :tag "Other")) 8733 :version "21.1" 8734 :group 'mail) 8735 8736(defcustom mail-user-agent 'message-user-agent 8737 "Your preference for a mail composition package. 8738Various Emacs Lisp packages (e.g. Reporter) require you to compose an 8739outgoing email message. This variable lets you specify which 8740mail-sending package you prefer. 8741 8742Valid values include: 8743 8744 `message-user-agent' -- use the Message package. 8745 See Info node `(message)'. 8746 `sendmail-user-agent' -- use the Mail package. 8747 See Info node `(emacs)Sending Mail'. 8748 `mh-e-user-agent' -- use the Emacs interface to the MH mail system. 8749 See Info node `(mh-e)'. 8750 `gnus-user-agent' -- like `message-user-agent', but with Gnus 8751 paraphernalia if Gnus is running, particularly 8752 the Gcc: header for archiving. 8753 8754Additional valid symbols may be available; check with the author of 8755your package for details. The function should return non-nil if it 8756succeeds. 8757 8758See also `read-mail-command' concerning reading mail." 8759 :type '(radio (function-item :tag "Message package" 8760 :format "%t\n" 8761 message-user-agent) 8762 (function-item :tag "Mail package" 8763 :format "%t\n" 8764 sendmail-user-agent) 8765 (function-item :tag "Emacs interface to MH" 8766 :format "%t\n" 8767 mh-e-user-agent) 8768 (function-item :tag "Message with full Gnus features" 8769 :format "%t\n" 8770 gnus-user-agent) 8771 (symbol :tag "Other")) 8772 :version "23.2" ; sendmail->message 8773 :group 'mail) 8774 8775(defcustom compose-mail-user-agent-warnings t 8776 "If non-nil, `compose-mail' warns about changes in `mail-user-agent'. 8777If the value of `mail-user-agent' is the default, and the user 8778appears to have customizations applying to the old default, 8779`compose-mail' issues a warning." 8780 :type 'boolean 8781 :version "23.2" 8782 :group 'mail) 8783 8784(defun rfc822-goto-eoh () 8785 "If the buffer starts with a mail header, move point to the header's end. 8786Otherwise, moves to `point-min'. 8787The end of the header is the start of the next line, if there is one, 8788else the end of the last line. This function obeys RFC 822 (or later)." 8789 (goto-char (point-min)) 8790 (when (re-search-forward 8791 "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) 8792 (goto-char (match-beginning 0)))) 8793 8794;; Used by Rmail (e.g., rmail-forward). 8795(defvar mail-encode-mml nil 8796 "If non-nil, mail-user-agent's `sendfunc' command should mml-encode 8797the outgoing message before sending it.") 8798 8799(defun compose-mail (&optional to subject other-headers continue 8800 switch-function yank-action send-actions 8801 return-action) 8802 "Start composing a mail message to send. 8803This uses the user's chosen mail composition package 8804as selected with the variable `mail-user-agent'. 8805The optional arguments TO and SUBJECT specify recipients 8806and the initial Subject field, respectively. 8807 8808OTHER-HEADERS is an alist specifying additional 8809header fields. Elements look like (HEADER . VALUE) where both 8810HEADER and VALUE are strings. 8811 8812By default, if an unsent message is already being composed, this 8813command will ask whether to erase the unsent message, and will not 8814start a new message if the user doesn't allow erasing. However, if 8815CONTINUE is non-nil, it means to continue editing a message already 8816being composed without asking. Interactively, CONTINUE is the prefix 8817argument. 8818 8819SWITCH-FUNCTION, if non-nil, is a function to use to 8820switch to and display the buffer used for mail composition. 8821 8822YANK-ACTION, if non-nil, is an action to perform, if and when necessary, 8823to insert the raw text of the message being replied to. 8824It has the form (FUNCTION . ARGS). The user agent will apply 8825FUNCTION to ARGS, to insert the raw text of the original message. 8826\(The user agent will also run `mail-citation-hook', *after* the 8827original text has been inserted in this way.) 8828 8829SEND-ACTIONS is a list of actions to call when the message is sent. 8830Each action has the form (FUNCTION . ARGS). 8831 8832RETURN-ACTION, if non-nil, is an action for returning to the 8833caller. It has the form (FUNCTION . ARGS). The function is 8834called after the mail has been sent or put aside, and the mail 8835buffer buried." 8836 (interactive 8837 (list nil nil nil current-prefix-arg)) 8838 8839 ;; In Emacs 23.2, the default value of `mail-user-agent' changed 8840 ;; from sendmail-user-agent to message-user-agent. Some users may 8841 ;; encounter incompatibilities. This hack tries to detect problems 8842 ;; and warn about them. 8843 (and compose-mail-user-agent-warnings 8844 (eq mail-user-agent 'message-user-agent) 8845 (let (warn-vars) 8846 (dolist (var '(mail-mode-hook mail-send-hook mail-setup-hook 8847 mail-citation-hook mail-archive-file-name 8848 mail-default-reply-to mail-mailing-lists 8849 mail-self-blind)) 8850 (and (boundp var) 8851 (symbol-value var) 8852 (push var warn-vars))) 8853 (when warn-vars 8854 (display-warning 'mail 8855 (format-message "\ 8856The default mail mode is now Message mode. 8857You have the following Mail mode variable%s customized: 8858\n %s\n\nTo use Mail mode, set `mail-user-agent' to sendmail-user-agent. 8859To disable this warning, set `compose-mail-user-agent-warnings' to nil." 8860 (if (> (length warn-vars) 1) "s" "") 8861 (mapconcat 'symbol-name 8862 warn-vars " ")))))) 8863 8864 (let ((function (get mail-user-agent 'composefunc))) 8865 (unless function 8866 (error "Invalid value for `mail-user-agent'")) 8867 (funcall function to subject other-headers continue switch-function 8868 yank-action send-actions return-action))) 8869 8870(defun compose-mail-other-window (&optional to subject other-headers continue 8871 yank-action send-actions 8872 return-action) 8873 "Like \\[compose-mail], but edit the outgoing message in another window." 8874 (interactive (list nil nil nil current-prefix-arg)) 8875 (compose-mail to subject other-headers continue 8876 'switch-to-buffer-other-window yank-action send-actions 8877 return-action)) 8878 8879(defun compose-mail-other-frame (&optional to subject other-headers continue 8880 yank-action send-actions 8881 return-action) 8882 "Like \\[compose-mail], but edit the outgoing message in another frame." 8883 (interactive (list nil nil nil current-prefix-arg)) 8884 (compose-mail to subject other-headers continue 8885 'switch-to-buffer-other-frame yank-action send-actions 8886 return-action)) 8887 8888 8889(defvar set-variable-value-history nil 8890 "History of values entered with `set-variable'. 8891 8892Maximum length of the history list is determined by the value 8893of `history-length', which see.") 8894 8895(defun set-variable (variable value &optional make-local) 8896 "Set VARIABLE to VALUE. VALUE is a Lisp object. 8897VARIABLE should be a user option variable name, a Lisp variable 8898meant to be customized by users. You should enter VALUE in Lisp syntax, 8899so if you want VALUE to be a string, you must surround it with doublequotes. 8900VALUE is used literally, not evaluated. 8901 8902If VARIABLE has a `variable-interactive' property, that is used as if 8903it were the arg to `interactive' (which see) to interactively read VALUE. 8904 8905If VARIABLE has been defined with `defcustom', then the type information 8906in the definition is used to check that VALUE is valid. 8907 8908Note that this function is at heart equivalent to the basic `set' function. 8909For a variable defined with `defcustom', it does not pay attention to 8910any :set property that the variable might have (if you want that, use 8911\\[customize-set-variable] instead). 8912 8913With a prefix argument, set VARIABLE to VALUE buffer-locally. 8914 8915When called interactively, the user is prompted for VARIABLE and 8916then VALUE. The current value of VARIABLE will be put in the 8917minibuffer history so that it can be accessed with \\`M-n', which 8918makes it easier to edit it." 8919 (interactive 8920 (let* ((default-var (variable-at-point)) 8921 (var (if (custom-variable-p default-var) 8922 (read-variable (format-prompt "Set variable" default-var) 8923 default-var) 8924 (read-variable "Set variable: "))) 8925 (minibuffer-help-form `(describe-variable ',var)) 8926 (prop (get var 'variable-interactive)) 8927 (obsolete (car (get var 'byte-obsolete-variable))) 8928 (prompt (format "Set %s %s to value: " var 8929 (cond ((local-variable-p var) 8930 "(buffer-local)") 8931 ((or current-prefix-arg 8932 (local-variable-if-set-p var)) 8933 "buffer-locally") 8934 (t "globally")))) 8935 (val (progn 8936 (when obsolete 8937 (message (concat "`%S' is obsolete; " 8938 (if (symbolp obsolete) "use `%S' instead" "%s")) 8939 var obsolete) 8940 (sit-for 3)) 8941 (if prop 8942 ;; Use VAR's `variable-interactive' property 8943 ;; as an interactive spec for prompting. 8944 (call-interactively `(lambda (arg) 8945 (interactive ,prop) 8946 arg)) 8947 (read-from-minibuffer prompt nil 8948 read-expression-map t 8949 'set-variable-value-history 8950 (format "%S" (symbol-value var))))))) 8951 (list var val current-prefix-arg))) 8952 8953 (and (custom-variable-p variable) 8954 (not (get variable 'custom-type)) 8955 (custom-load-symbol variable)) 8956 (let ((type (get variable 'custom-type))) 8957 (when type 8958 ;; Match with custom type. 8959 (require 'cus-edit) 8960 (setq type (widget-convert type)) 8961 (unless (widget-apply type :match value) 8962 (user-error "Value `%S' does not match type %S of %S" 8963 value (car type) variable)))) 8964 8965 (if make-local 8966 (make-local-variable variable)) 8967 8968 (set variable value) 8969 8970 ;; Force a thorough redisplay for the case that the variable 8971 ;; has an effect on the display, like `tab-width' has. 8972 (force-mode-line-update)) 8973 8974;; Define the major mode for lists of completions. 8975 8976(defvar completion-list-mode-map 8977 (let ((map (make-sparse-keymap))) 8978 (set-keymap-parent map special-mode-map) 8979 (define-key map "g" nil) ;; There's nothing to revert from. 8980 (define-key map [mouse-2] 'choose-completion) 8981 (define-key map [follow-link] 'mouse-face) 8982 (define-key map [down-mouse-2] nil) 8983 (define-key map "\C-m" 'choose-completion) 8984 (define-key map "\e\e\e" 'delete-completion-window) 8985 (define-key map [remap keyboard-quit] #'delete-completion-window) 8986 (define-key map [left] 'previous-completion) 8987 (define-key map [right] 'next-completion) 8988 (define-key map [?\t] 'next-completion) 8989 (define-key map [backtab] 'previous-completion) 8990 (define-key map "z" 'kill-current-buffer) 8991 (define-key map "n" 'next-completion) 8992 (define-key map "p" 'previous-completion) 8993 (define-key map "\M-g\M-c" 'switch-to-minibuffer) 8994 map) 8995 "Local map for completion list buffers.") 8996 8997;; Completion mode is suitable only for specially formatted data. 8998(put 'completion-list-mode 'mode-class 'special) 8999 9000(defvar completion-reference-buffer nil 9001 "Record the buffer that was current when the completion list was requested. 9002This is a local variable in the completion list buffer. 9003Initial value is nil to avoid some compiler warnings.") 9004 9005(defvar completion-no-auto-exit nil 9006 "Non-nil means `choose-completion-string' should never exit the minibuffer. 9007This also applies to other functions such as `choose-completion'.") 9008 9009(defvar completion-base-position nil 9010 "Position of the base of the text corresponding to the shown completions. 9011This variable is used in the *Completions* buffers. 9012Its value is a list of the form (START END) where START is the place 9013where the completion should be inserted and END (if non-nil) is the end 9014of the text to replace. If END is nil, point is used instead.") 9015 9016(defvar completion-list-insert-choice-function #'completion--replace 9017 "Function to use to insert the text chosen in *Completions*. 9018Called with three arguments (BEG END TEXT), it should replace the text 9019between BEG and END with TEXT. Expected to be set buffer-locally 9020in the *Completions* buffer.") 9021 9022(defun delete-completion-window () 9023 "Delete the completion list window. 9024Go to the window from which completion was requested." 9025 (interactive) 9026 (let ((buf completion-reference-buffer)) 9027 (if (one-window-p t) 9028 (if (window-dedicated-p) (delete-frame)) 9029 (delete-window (selected-window)) 9030 (if (get-buffer-window buf) 9031 (select-window (get-buffer-window buf)))))) 9032 9033(defcustom completion-wrap-movement t 9034 "Non-nil means to wrap around when selecting completion options. 9035This affects the commands `next-completion' and 9036`previous-completion'." 9037 :type 'boolean 9038 :version "29.1" 9039 :group 'completion) 9040 9041(defun previous-completion (n) 9042 "Move to the previous item in the completion list. 9043With prefix argument N, move back N items (negative N means move 9044forward)." 9045 (interactive "p") 9046 (next-completion (- n))) 9047 9048(defun next-completion (n) 9049 "Move to the next item in the completion list. 9050With prefix argument N, move N items (negative N means move 9051backward)." 9052 (interactive "p") 9053 (let ((beg (point-min)) (end (point-max))) 9054 (catch 'bound 9055 (while (> n 0) 9056 ;; If in a completion, move to the end of it. 9057 (when (get-text-property (point) 'mouse-face) 9058 (goto-char (next-single-property-change (point) 'mouse-face nil end))) 9059 ;; If at the last completion option, wrap or skip to the 9060 ;; minibuffer, if requested. 9061 (when (and completion-wrap-movement (eobp)) 9062 (if (and (member (this-command-keys) '("\t" [backtab])) 9063 completion-auto-select) 9064 (throw 'bound nil) 9065 (goto-char (point-min)))) 9066 ;; Move to start of next one. 9067 (unless (get-text-property (point) 'mouse-face) 9068 (goto-char (next-single-property-change (point) 'mouse-face nil end))) 9069 (setq n (1- n))) 9070 (while (< n 0) 9071 (let ((prop (get-text-property (1- (point)) 'mouse-face))) 9072 ;; If in a completion, move to the start of it. 9073 (when (and prop (eq prop (get-text-property (point) 'mouse-face))) 9074 (goto-char (previous-single-property-change 9075 (point) 'mouse-face nil beg))) 9076 ;; Move to end of the previous completion. 9077 (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face)) 9078 (goto-char (previous-single-property-change 9079 (point) 'mouse-face nil beg))) 9080 ;; If at the first completion option, wrap or skip to the 9081 ;; minibuffer, if requested. 9082 (when (and completion-wrap-movement (bobp)) 9083 (if (and (member (this-command-keys) '("\t" [backtab])) 9084 completion-auto-select) 9085 (progn 9086 (goto-char (next-single-property-change (point) 'mouse-face nil end)) 9087 (throw 'bound nil)) 9088 (goto-char (point-max)))) 9089 ;; Move to the start of that one. 9090 (goto-char (previous-single-property-change 9091 (point) 'mouse-face nil beg)) 9092 (setq n (1+ n))))) 9093 (when (/= 0 n) 9094 (switch-to-minibuffer)))) 9095 9096(defun choose-completion (&optional event) 9097 "Choose the completion at point. 9098If EVENT, use EVENT's position to determine the starting position." 9099 (interactive (list last-nonmenu-event)) 9100 ;; In case this is run via the mouse, give temporary modes such as 9101 ;; isearch a chance to turn off. 9102 (run-hooks 'mouse-leave-buffer-hook) 9103 (with-current-buffer (window-buffer (posn-window (event-start event))) 9104 (let ((buffer completion-reference-buffer) 9105 (base-position completion-base-position) 9106 (insert-function completion-list-insert-choice-function) 9107 (choice 9108 (save-excursion 9109 (goto-char (posn-point (event-start event))) 9110 (let (beg) 9111 (cond 9112 ((and (not (eobp)) (get-text-property (point) 'mouse-face)) 9113 (setq beg (1+ (point)))) 9114 ((and (not (bobp)) 9115 (get-text-property (1- (point)) 'mouse-face)) 9116 (setq beg (point))) 9117 (t (error "No completion here"))) 9118 (setq beg (previous-single-property-change beg 'mouse-face)) 9119 (substring-no-properties 9120 (get-text-property beg 'completion--string)))))) 9121 9122 (unless (buffer-live-p buffer) 9123 (error "Destination buffer is dead")) 9124 (quit-window nil (posn-window (event-start event))) 9125 9126 (with-current-buffer buffer 9127 (choose-completion-string 9128 choice buffer 9129 (or base-position 9130 ;; If all else fails, just guess. 9131 (list (choose-completion-guess-base-position choice))) 9132 insert-function))))) 9133 9134;; Delete the longest partial match for STRING 9135;; that can be found before POINT. 9136(defun choose-completion-guess-base-position (string) 9137 (save-excursion 9138 (let ((opoint (point)) 9139 len) 9140 ;; Try moving back by the length of the string. 9141 (goto-char (max (- (point) (length string)) 9142 (minibuffer-prompt-end))) 9143 ;; See how far back we were actually able to move. That is the 9144 ;; upper bound on how much we can match and delete. 9145 (setq len (- opoint (point))) 9146 (if completion-ignore-case 9147 (setq string (downcase string))) 9148 (while (and (> len 0) 9149 (let ((tail (buffer-substring (point) opoint))) 9150 (if completion-ignore-case 9151 (setq tail (downcase tail))) 9152 (not (string= tail (substring string 0 len))))) 9153 (setq len (1- len)) 9154 (forward-char 1)) 9155 (point)))) 9156 9157(defvar choose-completion-string-functions nil 9158 "Functions that may override the normal insertion of a completion choice. 9159These functions are called in order with three arguments: 9160CHOICE - the string to insert in the buffer, 9161BUFFER - the buffer in which the choice should be inserted, 9162BASE-POSITION - where to insert the completion. 9163 9164Functions should also accept and ignore a potential fourth 9165argument, passed for backwards compatibility. 9166 9167If a function in the list returns non-nil, that function is supposed 9168to have inserted the CHOICE in the BUFFER, and possibly exited 9169the minibuffer; no further functions will be called. 9170 9171If all functions in the list return nil, that means to use 9172the default method of inserting the completion in BUFFER.") 9173 9174(defun choose-completion-string (choice &optional 9175 buffer base-position insert-function) 9176 "Switch to BUFFER and insert the completion choice CHOICE. 9177BASE-POSITION says where to insert the completion. 9178INSERT-FUNCTION says how to insert the completion and falls 9179back on `completion-list-insert-choice-function' when nil." 9180 9181 ;; If BUFFER is the minibuffer, exit the minibuffer 9182 ;; unless it is reading a file name and CHOICE is a directory, 9183 ;; or completion-no-auto-exit is non-nil. 9184 9185 (let* ((buffer (or buffer completion-reference-buffer)) 9186 (mini-p (minibufferp buffer))) 9187 ;; If BUFFER is a minibuffer, barf unless it's the currently 9188 ;; active minibuffer. 9189 (if (and mini-p 9190 (not (and (active-minibuffer-window) 9191 (equal buffer 9192 (window-buffer (active-minibuffer-window)))))) 9193 (error "Minibuffer is not active for completion") 9194 ;; Set buffer so buffer-local choose-completion-string-functions works. 9195 (set-buffer buffer) 9196 (unless (run-hook-with-args-until-success 9197 'choose-completion-string-functions 9198 ;; The fourth arg used to be `mini-p' but was useless 9199 ;; (since minibufferp can be used on the `buffer' arg) 9200 ;; and indeed unused. The last used to be `base-size', so we 9201 ;; keep it to try and avoid breaking old code. 9202 choice buffer base-position nil) 9203 ;; This remove-text-properties should be unnecessary since `choice' 9204 ;; comes from buffer-substring-no-properties. 9205 ;;(remove-text-properties 0 (length choice) '(mouse-face nil) choice) 9206 ;; Insert the completion into the buffer where it was requested. 9207 (funcall (or insert-function completion-list-insert-choice-function) 9208 (or (car base-position) (point)) 9209 (or (cadr base-position) (point)) 9210 choice) 9211 ;; Update point in the window that BUFFER is showing in. 9212 (let ((window (get-buffer-window buffer t))) 9213 (set-window-point window (point))) 9214 ;; If completing for the minibuffer, exit it with this choice. 9215 (and (not completion-no-auto-exit) 9216 (minibufferp buffer) 9217 minibuffer-completion-table 9218 ;; If this is reading a file name, and the file name chosen 9219 ;; is a directory, don't exit the minibuffer. 9220 (let* ((result (buffer-substring (field-beginning) (point))) 9221 (bounds 9222 (completion-boundaries result minibuffer-completion-table 9223 minibuffer-completion-predicate 9224 ""))) 9225 (if (eq (car bounds) (length result)) 9226 ;; The completion chosen leads to a new set of completions 9227 ;; (e.g. it's a directory): don't exit the minibuffer yet. 9228 (let ((mini (active-minibuffer-window))) 9229 (select-window mini) 9230 (when minibuffer-auto-raise 9231 (raise-frame (window-frame mini)))) 9232 (exit-minibuffer)))))))) 9233 9234(define-derived-mode completion-list-mode nil "Completion List" 9235 "Major mode for buffers showing lists of possible completions. 9236Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\ 9237 to select the completion near point. 9238Or click to select one with the mouse. 9239 9240See the `completions-format' user option to control how this 9241buffer is formatted. 9242 9243\\{completion-list-mode-map}") 9244 9245(defun completion-list-mode-finish () 9246 "Finish setup of the completions buffer. 9247Called from `temp-buffer-show-hook'." 9248 (when (eq major-mode 'completion-list-mode) 9249 (setq buffer-read-only t))) 9250 9251(add-hook 'temp-buffer-show-hook 'completion-list-mode-finish) 9252 9253 9254;; Variables and faces used in `completion-setup-function'. 9255 9256(defcustom completion-show-help t 9257 "Non-nil means show help message in *Completions* buffer." 9258 :type 'boolean 9259 :version "22.1" 9260 :group 'completion) 9261 9262(defcustom completion-auto-select nil 9263 "Non-nil means to automatically select the *Completions* buffer." 9264 :type 'boolean 9265 :version "29.1" 9266 :group 'completion) 9267 9268;; This function goes in completion-setup-hook, so that it is called 9269;; after the text of the completion list buffer is written. 9270(defun completion-setup-function () 9271 (let* ((mainbuf (current-buffer)) 9272 (base-dir 9273 ;; FIXME: This is a bad hack. We try to set the default-directory 9274 ;; in the *Completions* buffer so that the relative file names 9275 ;; displayed there can be treated as valid file names, independently 9276 ;; from the completion context. But this suffers from many problems: 9277 ;; - It's not clear when the completions are file names. With some 9278 ;; completion tables (e.g. bzr revision specs), the listed 9279 ;; completions can mix file names and other things. 9280 ;; - It doesn't pay attention to possible quoting. 9281 ;; - With fancy completion styles, the code below will not always 9282 ;; find the right base directory. 9283 (if minibuffer-completing-file-name 9284 (file-name-as-directory 9285 (expand-file-name 9286 (buffer-substring (minibuffer-prompt-end) (point))))))) 9287 (with-current-buffer standard-output 9288 (let ((base-position completion-base-position) 9289 (insert-fun completion-list-insert-choice-function)) 9290 (completion-list-mode) 9291 (setq-local completion-base-position base-position) 9292 (setq-local completion-list-insert-choice-function insert-fun)) 9293 (setq-local completion-reference-buffer mainbuf) 9294 (if base-dir (setq default-directory base-dir)) 9295 (when completion-tab-width 9296 (setq tab-width completion-tab-width)) 9297 ;; Maybe insert help string. 9298 (when completion-show-help 9299 (goto-char (point-min)) 9300 (if (display-mouse-p) 9301 (insert "Click on a completion to select it.\n")) 9302 (insert (substitute-command-keys 9303 "In this buffer, type \\[choose-completion] to \ 9304select the completion near point.\n\n"))))) 9305 (when completion-auto-select 9306 (switch-to-completions))) 9307 9308(add-hook 'completion-setup-hook #'completion-setup-function) 9309 9310(defun switch-to-completions () 9311 "Select the completion list window." 9312 (interactive) 9313 (let ((window (or (get-buffer-window "*Completions*" 0) 9314 ;; Make sure we have a completions window. 9315 (progn (minibuffer-completion-help) 9316 (get-buffer-window "*Completions*" 0))))) 9317 (when window 9318 (select-window window) 9319 (cond 9320 ((and (memq this-command '(completion-at-point minibuffer-complete)) 9321 (equal (this-command-keys) [backtab]) 9322 (bobp)) 9323 (goto-char (point-max)) 9324 (previous-completion 1)) 9325 ;; In the new buffer, go to the first completion. 9326 ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'. 9327 ((bobp) 9328 (next-completion 1)))))) 9329 9330(defun read-expression-switch-to-completions () 9331 "Select the completion list window while reading an expression." 9332 (interactive) 9333 (completion-help-at-point) 9334 (switch-to-completions)) 9335 9336(defun switch-to-minibuffer () 9337 "Select the minibuffer window." 9338 (interactive) 9339 (when (active-minibuffer-window) 9340 (select-window (active-minibuffer-window)))) 9341 9342;;; Support keyboard commands to turn on various modifiers. 9343 9344;; These functions -- which are not commands -- each add one modifier 9345;; to the following event. 9346 9347(defun event-apply-alt-modifier (_ignore-prompt) 9348 "\\<function-key-map>Add the Alt modifier to the following event. 9349For example, type \\[event-apply-alt-modifier] & to enter Alt-&." 9350 (vector (event-apply-modifier (read-event) 'alt 22 "A-"))) 9351(defun event-apply-super-modifier (_ignore-prompt) 9352 "\\<function-key-map>Add the Super modifier to the following event. 9353For example, type \\[event-apply-super-modifier] & to enter Super-&." 9354 (vector (event-apply-modifier (read-event) 'super 23 "s-"))) 9355(defun event-apply-hyper-modifier (_ignore-prompt) 9356 "\\<function-key-map>Add the Hyper modifier to the following event. 9357For example, type \\[event-apply-hyper-modifier] & to enter Hyper-&." 9358 (vector (event-apply-modifier (read-event) 'hyper 24 "H-"))) 9359(defun event-apply-shift-modifier (_ignore-prompt) 9360 "\\<function-key-map>Add the Shift modifier to the following event. 9361For example, type \\[event-apply-shift-modifier] & to enter Shift-&." 9362 (vector (event-apply-modifier (read-event) 'shift 25 "S-"))) 9363(defun event-apply-control-modifier (_ignore-prompt) 9364 "\\<function-key-map>Add the Ctrl modifier to the following event. 9365For example, type \\[event-apply-control-modifier] & to enter Ctrl-&." 9366 (vector (event-apply-modifier (read-event) 'control 26 "C-"))) 9367(defun event-apply-meta-modifier (_ignore-prompt) 9368 "\\<function-key-map>Add the Meta modifier to the following event. 9369For example, type \\[event-apply-meta-modifier] & to enter Meta-&." 9370 (vector (event-apply-modifier (read-event) 'meta 27 "M-"))) 9371 9372(defun event-apply-modifier (event symbol lshiftby prefix) 9373 "Apply a modifier flag to event EVENT. 9374SYMBOL is the name of this modifier, as a symbol. 9375LSHIFTBY is the numeric value of this modifier, in keyboard events. 9376PREFIX is the string that represents this modifier in an event type symbol." 9377 (if (numberp event) 9378 (cond ((eq symbol 'control) 9379 (if (<= 64 (upcase event) 95) 9380 (- (upcase event) 64) 9381 (logior (ash 1 lshiftby) event))) 9382 ((eq symbol 'shift) 9383 ;; FIXME: Should we also apply this "upcase" behavior of shift 9384 ;; to non-ascii letters? 9385 (if (and (<= (downcase event) ?z) 9386 (>= (downcase event) ?a)) 9387 (upcase event) 9388 (logior (ash 1 lshiftby) event))) 9389 (t 9390 (logior (ash 1 lshiftby) event))) 9391 (if (memq symbol (event-modifiers event)) 9392 event 9393 (let ((event-type (if (symbolp event) event (car event)))) 9394 (setq event-type (intern (concat prefix (symbol-name event-type)))) 9395 (if (symbolp event) 9396 event-type 9397 (cons event-type (cdr event))))))) 9398 9399(define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier) 9400(define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier) 9401(define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier) 9402(define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier) 9403(define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier) 9404(define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier) 9405 9406;;;; Keypad support. 9407 9408;; Make the keypad keys act like ordinary typing keys. If people add 9409;; bindings for the function key symbols, then those bindings will 9410;; override these, so this shouldn't interfere with any existing 9411;; bindings. 9412 9413;; Also tell read-char how to handle these keys. 9414(mapc 9415 (lambda (keypad-normal) 9416 (let ((keypad (nth 0 keypad-normal)) 9417 (normal (nth 1 keypad-normal))) 9418 (put keypad 'ascii-character normal) 9419 (define-key function-key-map (vector keypad) (vector normal)))) 9420 ;; See also kp-keys bound in bindings.el. 9421 '((kp-space ?\s) 9422 (kp-tab ?\t) 9423 (kp-enter ?\r) 9424 (kp-separator ?,) 9425 (kp-equal ?=) 9426 ;; Do the same for various keys that are represented as symbols under 9427 ;; GUIs but naturally correspond to characters. 9428 (backspace 127) 9429 (delete 127) 9430 (tab ?\t) 9431 (linefeed ?\n) 9432 (clear ?\C-l) 9433 (return ?\C-m) 9434 (escape ?\e) 9435 )) 9436 9437;;;; 9438;;;; forking a twin copy of a buffer. 9439;;;; 9440 9441(defvar clone-buffer-hook nil 9442 "Normal hook to run in the new buffer at the end of `clone-buffer'.") 9443 9444(defvar clone-indirect-buffer-hook nil 9445 "Normal hook to run in the new buffer at the end of `clone-indirect-buffer'.") 9446 9447(defun clone-process (process &optional newname) 9448 "Create a twin copy of PROCESS. 9449If NEWNAME is nil, it defaults to PROCESS' name; 9450NEWNAME is modified by adding or incrementing <N> at the end as necessary. 9451If PROCESS is associated with a buffer, the new process will be associated 9452 with the current buffer instead. 9453Returns nil if PROCESS has already terminated." 9454 (setq newname (or newname (process-name process))) 9455 (if (string-match "<[0-9]+>\\'" newname) 9456 (setq newname (substring newname 0 (match-beginning 0)))) 9457 (when (memq (process-status process) '(run stop open)) 9458 (let* ((process-connection-type (process-tty-name process)) 9459 (new-process 9460 (if (memq (process-status process) '(open)) 9461 (let ((args (process-contact process t))) 9462 (setq args (plist-put args :name newname)) 9463 (setq args (plist-put args :buffer 9464 (if (process-buffer process) 9465 (current-buffer)))) 9466 (apply 'make-network-process args)) 9467 (apply 'start-process newname 9468 (if (process-buffer process) (current-buffer)) 9469 (process-command process))))) 9470 (set-process-query-on-exit-flag 9471 new-process (process-query-on-exit-flag process)) 9472 (set-process-inherit-coding-system-flag 9473 new-process (process-inherit-coding-system-flag process)) 9474 (set-process-filter new-process (process-filter process)) 9475 (set-process-sentinel new-process (process-sentinel process)) 9476 (set-process-plist new-process (copy-sequence (process-plist process))) 9477 new-process))) 9478 9479;; things to maybe add (currently partly covered by `funcall mode'): 9480;; - syntax-table 9481;; - overlays 9482(defun clone-buffer (&optional newname display-flag) 9483 "Create and return a twin copy of the current buffer. 9484Unlike an indirect buffer, the new buffer can be edited 9485independently of the old one (if it is not read-only). 9486NEWNAME is the name of the new buffer. It may be modified by 9487adding or incrementing <N> at the end as necessary to create a 9488unique buffer name. If nil, it defaults to the name of the 9489current buffer, with the proper suffix. If DISPLAY-FLAG is 9490non-nil, the new buffer is shown with `pop-to-buffer'. Trying to 9491clone a file-visiting buffer, or a buffer whose major mode symbol 9492has a non-nil `no-clone' property, results in an error. 9493 9494Interactively, DISPLAY-FLAG is t and NEWNAME is the name of the 9495current buffer with appropriate suffix. However, if a prefix 9496argument is given, then the command prompts for NEWNAME in the 9497minibuffer. 9498 9499This runs the normal hook `clone-buffer-hook' in the new buffer 9500after it has been set up properly in other respects." 9501 (interactive 9502 (progn 9503 (if buffer-file-name 9504 (error "Cannot clone a file-visiting buffer")) 9505 (if (get major-mode 'no-clone) 9506 (error "Cannot clone a buffer in %s mode" mode-name)) 9507 (list (if current-prefix-arg 9508 (read-buffer "Name of new cloned buffer: " (current-buffer))) 9509 t))) 9510 (if buffer-file-name 9511 (error "Cannot clone a file-visiting buffer")) 9512 (if (get major-mode 'no-clone) 9513 (error "Cannot clone a buffer in %s mode" mode-name)) 9514 (setq newname (or newname (buffer-name))) 9515 (if (string-match "<[0-9]+>\\'" newname) 9516 (setq newname (substring newname 0 (match-beginning 0)))) 9517 (let ((buf (current-buffer)) 9518 (ptmin (point-min)) 9519 (ptmax (point-max)) 9520 (pt (point)) 9521 (mk (if mark-active (mark t))) 9522 (modified (buffer-modified-p)) 9523 (mode major-mode) 9524 (lvars (buffer-local-variables)) 9525 (process (get-buffer-process (current-buffer))) 9526 (new (generate-new-buffer (or newname (buffer-name))))) 9527 (save-restriction 9528 (widen) 9529 (with-current-buffer new 9530 (insert-buffer-substring buf))) 9531 (with-current-buffer new 9532 (narrow-to-region ptmin ptmax) 9533 (goto-char pt) 9534 (if mk (set-mark mk)) 9535 (set-buffer-modified-p modified) 9536 9537 ;; Clone the old buffer's process, if any. 9538 (when process (clone-process process)) 9539 9540 ;; Now set up the major mode. 9541 (funcall mode) 9542 9543 ;; Set up other local variables. 9544 (mapc (lambda (v) 9545 (condition-case () 9546 (if (symbolp v) 9547 (makunbound (make-local-variable v)) 9548 (set (make-local-variable (car v)) (cdr v))) 9549 (setting-constant nil))) ;E.g. for enable-multibyte-characters. 9550 lvars) 9551 9552 (setq mark-ring (mapcar (lambda (mk) (copy-marker (marker-position mk))) 9553 mark-ring)) 9554 9555 ;; Run any hooks (typically set up by the major mode 9556 ;; for cloning to work properly). 9557 (run-hooks 'clone-buffer-hook)) 9558 (if display-flag 9559 ;; Presumably the current buffer is shown in the selected frame, so 9560 ;; we want to display the clone elsewhere. 9561 (let ((same-window-regexps nil) 9562 (same-window-buffer-names)) 9563 (pop-to-buffer new))) 9564 new)) 9565 9566 9567(defun clone-indirect-buffer (newname display-flag &optional norecord) 9568 "Create an indirect buffer that is a twin copy of the current buffer. 9569 9570Give the indirect buffer name NEWNAME. Interactively, read NEWNAME 9571from the minibuffer when invoked with a prefix arg. If NEWNAME is nil 9572or if not called with a prefix arg, NEWNAME defaults to the current 9573buffer's name. The name is modified by adding a `<N>' suffix to it 9574or by incrementing the N in an existing suffix. Trying to clone a 9575buffer whose major mode symbol has a non-nil `no-clone-indirect' 9576property results in an error. 9577 9578DISPLAY-FLAG non-nil means show the new buffer with `pop-to-buffer'. 9579This is always done when called interactively. 9580 9581Optional third arg NORECORD non-nil means do not put this buffer at the 9582front of the list of recently selected ones. 9583 9584Returns the newly created indirect buffer." 9585 (interactive 9586 (progn 9587 (if (get major-mode 'no-clone-indirect) 9588 (error "Cannot indirectly clone a buffer in %s mode" mode-name)) 9589 (list (if current-prefix-arg 9590 (read-buffer "Name of indirect buffer: " (current-buffer))) 9591 t))) 9592 (if (get major-mode 'no-clone-indirect) 9593 (error "Cannot indirectly clone a buffer in %s mode" mode-name)) 9594 (setq newname (or newname (buffer-name))) 9595 (if (string-match "<[0-9]+>\\'" newname) 9596 (setq newname (substring newname 0 (match-beginning 0)))) 9597 (let* ((name (generate-new-buffer-name newname)) 9598 (buffer (make-indirect-buffer (current-buffer) name t))) 9599 (with-current-buffer buffer 9600 (run-hooks 'clone-indirect-buffer-hook)) 9601 (when display-flag 9602 (pop-to-buffer buffer nil norecord)) 9603 buffer)) 9604 9605 9606(defun clone-indirect-buffer-other-window (newname display-flag &optional norecord) 9607 "Like `clone-indirect-buffer' but display in another window." 9608 (interactive 9609 (progn 9610 (if (get major-mode 'no-clone-indirect) 9611 (error "Cannot indirectly clone a buffer in %s mode" mode-name)) 9612 (list (if current-prefix-arg 9613 (read-buffer "Name of indirect buffer: " (current-buffer))) 9614 t))) 9615 (let ((pop-up-windows t)) 9616 (clone-indirect-buffer newname display-flag norecord))) 9617 9618 9619;;; Handling of Backspace and Delete keys. 9620 9621(defcustom normal-erase-is-backspace 'maybe 9622 "Set the default behavior of the Delete and Backspace keys. 9623 9624If set to t, Delete key deletes forward and Backspace key deletes 9625backward. 9626 9627If set to nil, both Delete and Backspace keys delete backward. 9628 9629If set to `maybe' (which is the default), Emacs automatically 9630selects a behavior. On window systems, the behavior depends on 9631the keyboard used. If the keyboard has both a Backspace key and 9632a Delete key, and both are mapped to their usual meanings, the 9633option's default value is set to t, so that Backspace can be used 9634to delete backward, and Delete can be used to delete forward. 9635 9636If not running under a window system, customizing this option 9637accomplishes a similar effect by mapping C-h, which is usually 9638generated by the Backspace key, to DEL, and by mapping DEL to C-d 9639via `keyboard-translate'. The former functionality of C-h is 9640available on the F1 key. You should probably not use this 9641setting if you don't have both Backspace, Delete and F1 keys. 9642 9643Setting this variable with setq doesn't take effect. Programmatically, 9644call `normal-erase-is-backspace-mode' (which see) instead." 9645 :type '(choice (const :tag "Off" nil) 9646 (const :tag "Maybe" maybe) 9647 (other :tag "On" t)) 9648 :group 'editing-basics 9649 :version "21.1" 9650 :set (lambda (symbol value) 9651 ;; The fboundp is because of a problem with :set when 9652 ;; dumping Emacs. It doesn't really matter. 9653 (when (fboundp 'normal-erase-is-backspace-mode) 9654 (normal-erase-is-backspace-mode (or value 0))) 9655 (set-default symbol value))) 9656 9657(defun normal-erase-is-backspace-setup-frame (&optional frame) 9658 "Set up `normal-erase-is-backspace-mode' on FRAME, if necessary." 9659 (unless frame (setq frame (selected-frame))) 9660 (with-selected-frame frame 9661 (unless (terminal-parameter nil 'normal-erase-is-backspace) 9662 (normal-erase-is-backspace-mode 9663 (if (if (eq normal-erase-is-backspace 'maybe) 9664 (and (not noninteractive) 9665 (or (memq system-type '(ms-dos windows-nt)) 9666 (memq window-system '(w32 ns pgtk)) 9667 (and (eq window-system 'x) 9668 (fboundp 'x-backspace-delete-keys-p) 9669 (x-backspace-delete-keys-p)) 9670 ;; If the terminal Emacs is running on has erase char 9671 ;; set to ^H, use the Backspace key for deleting 9672 ;; backward, and the Delete key for deleting forward. 9673 (and (null window-system) 9674 (eq tty-erase-char ?\^H)))) 9675 normal-erase-is-backspace) 9676 1 0))))) 9677 9678(declare-function display-symbol-keys-p "frame" (&optional display)) 9679 9680(define-minor-mode normal-erase-is-backspace-mode 9681 "Toggle the Erase and Delete mode of the Backspace and Delete keys. 9682 9683On window systems, when this mode is on, Delete is mapped to C-d 9684and Backspace is mapped to DEL; when this mode is off, both 9685Delete and Backspace are mapped to DEL. (The remapping goes via 9686`local-function-key-map', so binding Delete or Backspace in the 9687global or local keymap will override that.) 9688 9689In addition, on window systems, the bindings of C-Delete, M-Delete, 9690C-M-Delete, C-Backspace, M-Backspace, and C-M-Backspace are changed in 9691the global keymap in accordance with the functionality of Delete and 9692Backspace. For example, if Delete is remapped to C-d, which deletes 9693forward, C-Delete is bound to `kill-word', but if Delete is remapped 9694to DEL, which deletes backward, C-Delete is bound to 9695`backward-kill-word'. 9696 9697If not running on a window system, a similar effect is accomplished by 9698remapping C-h (normally produced by the Backspace key) and DEL via 9699`keyboard-translate': if this mode is on, C-h is mapped to DEL and DEL 9700to C-d; if it's off, the keys are not remapped. 9701 9702When not running on a window system, and this mode is turned on, the 9703former functionality of C-h is available on the F1 key. You should 9704probably not turn on this mode on a text-only terminal if you don't 9705have both Backspace, Delete and F1 keys. 9706 9707See also `normal-erase-is-backspace'." 9708 :variable ((eq (terminal-parameter nil 'normal-erase-is-backspace) 1) 9709 . (lambda (v) 9710 (setf (terminal-parameter nil 'normal-erase-is-backspace) 9711 (if v 1 0)))) 9712 (let ((enabled (eq 1 (terminal-parameter 9713 nil 'normal-erase-is-backspace)))) 9714 9715 (cond ((display-symbol-keys-p) 9716 (let ((bindings 9717 '(([M-delete] [M-backspace]) 9718 ([C-M-delete] [C-M-backspace]) 9719 ([?\e C-delete] [?\e C-backspace])))) 9720 9721 (if enabled 9722 (progn 9723 (define-key local-function-key-map [delete] [deletechar]) 9724 (define-key local-function-key-map [kp-delete] [deletechar]) 9725 (define-key local-function-key-map [backspace] [?\C-?]) 9726 (dolist (b bindings) 9727 ;; Not sure if input-decode-map is really right, but 9728 ;; keyboard-translate-table (used below) works only 9729 ;; for integer events, and key-translation-table is 9730 ;; global (like the global-map, used earlier). 9731 (define-key input-decode-map (car b) nil) 9732 (define-key input-decode-map (cadr b) nil))) 9733 (define-key local-function-key-map [delete] [?\C-?]) 9734 (define-key local-function-key-map [kp-delete] [?\C-?]) 9735 (define-key local-function-key-map [backspace] [?\C-?]) 9736 (dolist (b bindings) 9737 (define-key input-decode-map (car b) (cadr b)) 9738 (define-key input-decode-map (cadr b) (car b)))))) 9739 (t 9740 (if enabled 9741 (progn 9742 (keyboard-translate ?\C-h ?\C-?) 9743 (keyboard-translate ?\C-? ?\C-d)) 9744 (keyboard-translate ?\C-h ?\C-h) 9745 (keyboard-translate ?\C-? ?\C-?)))) 9746 9747 (if (called-interactively-p 'interactive) 9748 (message "Delete key deletes %s" 9749 (if (eq 1 (terminal-parameter nil 'normal-erase-is-backspace)) 9750 "forward" "backward"))))) 9751 9752(defvar vis-mode-saved-buffer-invisibility-spec nil 9753 "Saved value of `buffer-invisibility-spec' when Visible mode is on.") 9754 9755(define-minor-mode read-only-mode 9756 "Change whether the current buffer is read-only. 9757 9758If buffer is read-only and `view-read-only' is non-nil, enter 9759view mode. 9760 9761Do not call this from a Lisp program unless you really intend to 9762do the same thing as the \\[read-only-mode] command, including 9763possibly enabling or disabling View mode. Also, note that this 9764command works by setting the variable `buffer-read-only', which 9765does not affect read-only regions caused by text properties. To 9766ignore read-only status in a Lisp program (whether due to text 9767properties or buffer state), bind `inhibit-read-only' temporarily 9768to a non-nil value." 9769 :variable buffer-read-only 9770 (cond 9771 ((and (not buffer-read-only) view-mode) 9772 (View-exit-and-edit) 9773 (setq-local view-read-only t)) ; Must leave view mode. 9774 ((and buffer-read-only view-read-only 9775 ;; If view-mode is already active, `view-mode-enter' is a nop. 9776 (not view-mode) 9777 (not (eq (get major-mode 'mode-class) 'special))) 9778 (view-mode-enter)))) 9779 9780(define-minor-mode visible-mode 9781 "Toggle making all invisible text temporarily visible (Visible mode). 9782 9783This mode works by saving the value of `buffer-invisibility-spec' 9784and setting it to nil." 9785 :lighter " Vis" 9786 :group 'editing-basics 9787 (when (local-variable-p 'vis-mode-saved-buffer-invisibility-spec) 9788 (setq buffer-invisibility-spec vis-mode-saved-buffer-invisibility-spec) 9789 (kill-local-variable 'vis-mode-saved-buffer-invisibility-spec)) 9790 (when visible-mode 9791 (setq-local vis-mode-saved-buffer-invisibility-spec 9792 buffer-invisibility-spec) 9793 (setq buffer-invisibility-spec nil))) 9794 9795(defvar messages-buffer-mode-map 9796 (let ((map (make-sparse-keymap))) 9797 (set-keymap-parent map special-mode-map) 9798 (define-key map "g" nil) ; nothing to revert 9799 map)) 9800 9801(define-derived-mode messages-buffer-mode special-mode "Messages" 9802 "Major mode used in the \"*Messages*\" buffer.") 9803 9804(defun messages-buffer () 9805 "Return the \"*Messages*\" buffer. 9806If it does not exist, create it and switch it to `messages-buffer-mode'." 9807 (or (get-buffer "*Messages*") 9808 (with-current-buffer (get-buffer-create "*Messages*") 9809 (messages-buffer-mode) 9810 (current-buffer)))) 9811 9812 9813;; Minibuffer prompt stuff. 9814 9815;;(defun minibuffer-prompt-modification (start end) 9816;; (error "You cannot modify the prompt")) 9817;; 9818;; 9819;;(defun minibuffer-prompt-insertion (start end) 9820;; (let ((inhibit-modification-hooks t)) 9821;; (delete-region start end) 9822;; ;; Discard undo information for the text insertion itself 9823;; ;; and for the text deletion.above. 9824;; (when (consp buffer-undo-list) 9825;; (setq buffer-undo-list (cddr buffer-undo-list))) 9826;; (message "You cannot modify the prompt"))) 9827;; 9828;; 9829;;(setq minibuffer-prompt-properties 9830;; (list 'modification-hooks '(minibuffer-prompt-modification) 9831;; 'insert-in-front-hooks '(minibuffer-prompt-insertion))) 9832 9833 9834;;;; Problematic external packages. 9835 9836;; rms says this should be done by specifying symbols that define 9837;; versions together with bad values. This is therefore not as 9838;; flexible as it could be. See the thread: 9839;; https://lists.gnu.org/r/emacs-devel/2007-08/msg00300.html 9840(defconst bad-packages-alist nil 9841 "Alist of packages known to cause problems in this version of Emacs. 9842Each element has the form (PACKAGE SYMBOL REGEXP STRING). 9843PACKAGE is either a regular expression to match file names, or a 9844symbol (a feature name), like for `with-eval-after-load'. 9845SYMBOL is either the name of a string variable, or t. Upon 9846loading PACKAGE, if SYMBOL is t or matches REGEXP, display a 9847warning using STRING as the message.") 9848(make-obsolete-variable 'bad-packages-alist nil "29.1") 9849 9850(defun bad-package-check (package) 9851 "Run a check using the element from `bad-packages-alist' matching PACKAGE." 9852 (declare (obsolete nil "29.1")) 9853 (condition-case nil 9854 (let* ((list (assoc package bad-packages-alist)) 9855 (symbol (nth 1 list))) 9856 (and list 9857 (boundp symbol) 9858 (or (eq symbol t) 9859 (and (stringp (setq symbol (eval symbol))) 9860 (string-match-p (nth 2 list) symbol))) 9861 (display-warning package (nth 3 list) :warning))) 9862 (error nil))) 9863 9864 9865;;; Generic dispatcher commands 9866 9867;; Macro `define-alternatives' is used to create generic commands. 9868;; Generic commands are these (like web, mail, news, encrypt, irc, etc.) 9869;; that can have different alternative implementations where choosing 9870;; among them is exclusively a matter of user preference. 9871 9872;; (define-alternatives COMMAND) creates a new interactive command 9873;; M-x COMMAND and a customizable variable COMMAND-alternatives. 9874;; Typically, the user will not need to customize this variable; packages 9875;; wanting to add alternative implementations should use 9876;; 9877;; ;;;###autoload (push '("My impl name" . my-impl-symbol) COMMAND-alternatives 9878 9879(defmacro define-alternatives (command &rest customizations) 9880 "Define the new command `COMMAND'. 9881 9882The argument `COMMAND' should be a symbol. 9883 9884Running `\\[execute-extended-command] COMMAND RET' for \ 9885the first time prompts for which 9886alternative to use and records the selected command as a custom 9887variable. 9888 9889Running `\\[universal-argument] \\[execute-extended-command] COMMAND RET' \ 9890prompts again for an alternative 9891and overwrites the previous choice. 9892 9893The variable `COMMAND-alternatives' contains an alist with 9894alternative implementations of COMMAND. `define-alternatives' 9895does not have any effect until this variable is set. 9896 9897CUSTOMIZATIONS, if non-nil, should be composed of alternating 9898`defcustom' keywords and values to add to the declaration of 9899`COMMAND-alternatives' (typically :group and :version)." 9900 (declare (indent defun)) 9901 (let* ((command-name (symbol-name command)) 9902 (varalt-name (concat command-name "-alternatives")) 9903 (varalt-sym (intern varalt-name)) 9904 (varimp-sym (intern (concat command-name "--implementation")))) 9905 `(progn 9906 9907 (defcustom ,varalt-sym nil 9908 ,(format "Alist of alternative implementations for the `%s' command. 9909 9910Each entry must be a pair (ALTNAME . ALTFUN), where: 9911ALTNAME - The name shown at user to describe the alternative implementation. 9912ALTFUN - The function called to implement this alternative." 9913 command-name) 9914 :type '(alist :key-type string :value-type function) 9915 ,@customizations) 9916 9917 (put ',varalt-sym 'definition-name ',command) 9918 (defvar ,varimp-sym nil "Internal use only.") 9919 9920 (defun ,command (&optional arg) 9921 ,(format "Run generic command `%s'. 9922If used for the first time, or with interactive ARG, ask the user which 9923implementation to use for `%s'. The variable `%s' 9924contains the list of implementations currently supported for this command." 9925 command-name command-name varalt-name) 9926 (interactive "P") 9927 (when (or arg (null ,varimp-sym)) 9928 (let ((val (completing-read 9929 ,(format-message 9930 "Select implementation for command `%s': " 9931 command-name) 9932 ,varalt-sym nil t))) 9933 (unless (string-equal val "") 9934 (when (null ,varimp-sym) 9935 (message 9936 "Use `C-u M-x %s RET' to select another implementation" 9937 ,command-name) 9938 (sit-for 3)) 9939 (customize-save-variable ',varimp-sym 9940 (cdr (assoc-string val ,varalt-sym)))))) 9941 (if ,varimp-sym 9942 (call-interactively ,varimp-sym) 9943 (message "%s" ,(format-message 9944 "No implementation selected for command `%s'" 9945 command-name))))))) 9946 9947 9948;;; Functions for changing capitalization that Do What I Mean 9949(defun upcase-dwim (arg) 9950 "Upcase words in the region, if active; if not, upcase word at point. 9951If the region is active, this function calls `upcase-region'. 9952Otherwise, it calls `upcase-word', with prefix argument passed to it 9953to upcase ARG words." 9954 (interactive "*p") 9955 (if (use-region-p) 9956 (upcase-region (region-beginning) (region-end) (region-noncontiguous-p)) 9957 (upcase-word arg))) 9958 9959(defun downcase-dwim (arg) 9960 "Downcase words in the region, if active; if not, downcase word at point. 9961If the region is active, this function calls `downcase-region'. 9962Otherwise, it calls `downcase-word', with prefix argument passed to it 9963to downcase ARG words." 9964 (interactive "*p") 9965 (if (use-region-p) 9966 (downcase-region (region-beginning) (region-end) (region-noncontiguous-p)) 9967 (downcase-word arg))) 9968 9969(defun capitalize-dwim (arg) 9970 "Capitalize words in the region, if active; if not, capitalize word at point. 9971If the region is active, this function calls `capitalize-region'. 9972Otherwise, it calls `capitalize-word', with prefix argument passed to it 9973to capitalize ARG words." 9974 (interactive "*p") 9975 (if (use-region-p) 9976 (capitalize-region (region-beginning) (region-end) (region-noncontiguous-p)) 9977 (capitalize-word arg))) 9978 9979;;; Accessors for `decode-time' values. 9980 9981(cl-defstruct (decoded-time 9982 (:constructor nil) 9983 (:copier nil) 9984 (:type list)) 9985 (second nil :documentation "\ 9986This is an integer or a Lisp timestamp (TICKS . HZ) representing a nonnegative 9987number of seconds less than 61. (If not less than 60, it is a leap second, 9988which only some operating systems support.)") 9989 (minute nil :documentation "This is an integer between 0 and 59 (inclusive).") 9990 (hour nil :documentation "This is an integer between 0 and 23 (inclusive).") 9991 (day nil :documentation "This is an integer between 1 and 31 (inclusive).") 9992 (month nil :documentation "\ 9993This is an integer between 1 and 12 (inclusive). January is 1.") 9994 (year nil :documentation "This is a four digit integer.") 9995 (weekday nil :documentation "\ 9996This is a number between 0 and 6, and 0 is Sunday.") 9997 (dst nil :documentation "\ 9998This is t if daylight saving time is in effect, nil if it is not 9999in effect, and -1 if daylight saving information is not 10000available.") 10001 (zone nil :documentation "\ 10002This is an integer indicating the UTC offset in seconds, i.e., 10003the number of seconds east of Greenwich.") 10004 ) 10005 10006 10007 10008(provide 'simple) 10009 10010;;; simple.el ends here 10011