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