;;; simple.el --- basic editing commands for Emacs
-;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002
+;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+;; 2000, 2001, 2002, 2003, 2004, 2005
;; Free Software Foundation, Inc.
+;; Maintainer: FSF
+;; Keywords: internal
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
(eval-when-compile
(autoload 'widget-convert "wid-edit")
- (autoload 'shell-mode "shell")
- (require 'cl))
+ (autoload 'shell-mode "shell"))
+(defcustom idle-update-delay 0.5
+ "*Idle time delay before updating various things on the screen.
+Various Emacs features that update auxiliary information when point moves
+wait this many seconds after Emacs becomes idle before doing an update."
+ :type 'number
+ :group 'display
+ :version "22.1")
(defgroup killing nil
- "Killing and yanking commands"
+ "Killing and yanking commands."
:group 'editing)
(defgroup paren-matching nil
"Highlight (un)matching of parens and expressions."
:group 'matching)
+(defun next-buffer ()
+ "Switch to the next buffer in cyclic order."
+ (interactive)
+ (let ((buffer (current-buffer)))
+ (switch-to-buffer (other-buffer buffer))
+ (bury-buffer buffer)))
+
+(defun prev-buffer ()
+ "Switch to the previous buffer in cyclic order."
+ (interactive)
+ (let ((list (nreverse (buffer-list)))
+ found)
+ (while (and (not found) list)
+ (let ((buffer (car list)))
+ (if (and (not (get-buffer-window buffer))
+ (not (string-match "\\` " (buffer-name buffer))))
+ (setq found buffer)))
+ (setq list (cdr list)))
+ (switch-to-buffer found)))
+\f
+;;; next-error support framework
+
+(defgroup next-error nil
+ "next-error support framework."
+ :group 'compilation
+ :version "22.1")
+
+(defface next-error
+ '((t (:inherit region)))
+ "Face used to highlight next error locus."
+ :group 'next-error
+ :version "22.1")
+
+(defcustom next-error-highlight 0.1
+ "*Highlighting of locations in selected source buffers.
+If number, highlight the locus in next-error face for given time in seconds.
+If t, use persistent overlays fontified in next-error face.
+If nil, don't highlight the locus in the source buffer.
+If `fringe-arrow', indicate the locus by the fringe arrow."
+ :type '(choice (number :tag "Delay")
+ (const :tag "Persistent overlay" t)
+ (const :tag "No highlighting" nil)
+ (const :tag "Fringe arrow" 'fringe-arrow))
+ :group 'next-error
+ :version "22.1")
+
+(defcustom next-error-highlight-no-select 0.1
+ "*Highlighting of locations in non-selected source buffers.
+If number, highlight the locus in next-error face for given time in seconds.
+If t, use persistent overlays fontified in next-error face.
+If nil, don't highlight the locus in the source buffer.
+If `fringe-arrow', indicate the locus by the fringe arrow."
+ :type '(choice (number :tag "Delay")
+ (const :tag "Persistent overlay" t)
+ (const :tag "No highlighting" nil)
+ (const :tag "Fringe arrow" 'fringe-arrow))
+ :group 'next-error
+ :version "22.1")
+
+(defvar next-error-highlight-timer nil)
+
+(defvar next-error-overlay-arrow-position nil)
+(put 'next-error-overlay-arrow-position 'overlay-arrow-string "=>")
+(add-to-list 'overlay-arrow-variable-list 'next-error-overlay-arrow-position)
+
+(defvar next-error-last-buffer nil
+ "The most recent next-error buffer.
+A buffer becomes most recent when its compilation, grep, or
+similar mode is started, or when it is used with \\[next-error]
+or \\[compile-goto-error].")
+
+(defvar next-error-function nil
+ "Function to use to find the next error in the current buffer.
+The function is called with 2 parameters:
+ARG is an integer specifying by how many errors to move.
+RESET is a boolean which, if non-nil, says to go back to the beginning
+of the errors before moving.
+Major modes providing compile-like functionality should set this variable
+to indicate to `next-error' that this is a candidate buffer and how
+to navigate in it.")
+
+(make-variable-buffer-local 'next-error-function)
+
+(defsubst next-error-buffer-p (buffer
+ &optional avoid-current
+ extra-test-inclusive
+ extra-test-exclusive)
+ "Test if BUFFER is a next-error capable buffer.
+
+If AVOID-CURRENT is non-nil, treat the current buffer
+as an absolute last resort only.
+
+The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer
+that normally would not qualify. If it returns t, the buffer
+in question is treated as usable.
+
+The function EXTRA-TEST-EXCLUSIVE, if non-nil is called in each buffer
+that would normally be considered usable. if it returns nil,
+that buffer is rejected."
+ (and (buffer-name buffer) ;First make sure it's live.
+ (not (and avoid-current (eq buffer (current-buffer))))
+ (with-current-buffer buffer
+ (if next-error-function ; This is the normal test.
+ ;; Optionally reject some buffers.
+ (if extra-test-exclusive
+ (funcall extra-test-exclusive)
+ t)
+ ;; Optionally accept some other buffers.
+ (and extra-test-inclusive
+ (funcall extra-test-inclusive))))))
+
+(defun next-error-find-buffer (&optional avoid-current
+ extra-test-inclusive
+ extra-test-exclusive)
+ "Return a next-error capable buffer.
+If AVOID-CURRENT is non-nil, treat the current buffer
+as an absolute last resort only.
+
+The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffers
+that normally would not qualify. If it returns t, the buffer
+in question is treated as usable.
+
+The function EXTRA-TEST-EXCLUSIVE, if non-nil is called in each buffer
+that would normally be considered usable. If it returns nil,
+that buffer is rejected."
+ (or
+ ;; 1. If one window on the selected frame displays such buffer, return it.
+ (let ((window-buffers
+ (delete-dups
+ (delq nil (mapcar (lambda (w)
+ (if (next-error-buffer-p
+ (window-buffer w)
+ avoid-current
+ extra-test-inclusive extra-test-exclusive)
+ (window-buffer w)))
+ (window-list))))))
+ (if (eq (length window-buffers) 1)
+ (car window-buffers)))
+ ;; 2. If next-error-last-buffer is an acceptable buffer, use that.
+ (if (and next-error-last-buffer
+ (next-error-buffer-p next-error-last-buffer avoid-current
+ extra-test-inclusive extra-test-exclusive))
+ next-error-last-buffer)
+ ;; 3. If the current buffer is acceptable, choose it.
+ (if (next-error-buffer-p (current-buffer) avoid-current
+ extra-test-inclusive extra-test-exclusive)
+ (current-buffer))
+ ;; 4. Look for any acceptable buffer.
+ (let ((buffers (buffer-list)))
+ (while (and buffers
+ (not (next-error-buffer-p
+ (car buffers) avoid-current
+ extra-test-inclusive extra-test-exclusive)))
+ (setq buffers (cdr buffers)))
+ (car buffers))
+ ;; 5. Use the current buffer as a last resort if it qualifies,
+ ;; even despite AVOID-CURRENT.
+ (and avoid-current
+ (next-error-buffer-p (current-buffer) nil
+ extra-test-inclusive extra-test-exclusive)
+ (progn
+ (message "This is the only next-error capable buffer")
+ (current-buffer)))
+ ;; 6. Give up.
+ (error "No next-error capable buffer found")))
+
+(defun next-error (&optional arg reset)
+ "Visit next next-error message and corresponding source code.
+
+If all the error messages parsed so far have been processed already,
+the message buffer is checked for new ones.
+
+A prefix ARG specifies how many error messages to move;
+negative means move back to previous error messages.
+Just \\[universal-argument] as a prefix means reparse the error message buffer
+and start at the first error.
+
+The RESET argument specifies that we should restart from the beginning.
+
+\\[next-error] normally uses the most recently started
+compilation, grep, or occur buffer. It can also operate on any
+buffer with output from the \\[compile], \\[grep] commands, or,
+more generally, on any buffer in Compilation mode or with
+Compilation Minor mode enabled, or any buffer in which
+`next-error-function' is bound to an appropriate function.
+To specify use of a particular buffer for error messages, type
+\\[next-error] in that buffer when it is the only one displayed
+in the current frame.
+
+Once \\[next-error] has chosen the buffer for error messages,
+it stays with that buffer until you use it in some other buffer which
+uses Compilation mode or Compilation Minor mode.
+
+See variables `compilation-parse-errors-function' and
+\`compilation-error-regexp-alist' for customization ideas."
+ (interactive "P")
+ (if (consp arg) (setq reset t arg nil))
+ (when (setq next-error-last-buffer (next-error-find-buffer))
+ ;; we know here that next-error-function is a valid symbol we can funcall
+ (with-current-buffer next-error-last-buffer
+ (funcall next-error-function (prefix-numeric-value arg) reset))))
+
+(defalias 'goto-next-locus 'next-error)
+(defalias 'next-match 'next-error)
+
+(defun previous-error (&optional n)
+ "Visit previous next-error message and corresponding source code.
+
+Prefix arg N says how many error messages to move backwards (or
+forwards, if negative).
+
+This operates on the output from the \\[compile] and \\[grep] commands."
+ (interactive "p")
+ (next-error (- (or n 1))))
+
+(defun first-error (&optional n)
+ "Restart at the first error.
+Visit corresponding source code.
+With prefix arg N, visit the source code of the Nth error.
+This operates on the output from the \\[compile] command, for instance."
+ (interactive "p")
+ (next-error n t))
+
+(defun next-error-no-select (&optional n)
+ "Move point to the next error in the next-error buffer and highlight match.
+Prefix arg N says how many error messages to move forwards (or
+backwards, if negative).
+Finds and highlights the source line like \\[next-error], but does not
+select the source buffer."
+ (interactive "p")
+ (let ((next-error-highlight next-error-highlight-no-select))
+ (next-error n))
+ (pop-to-buffer next-error-last-buffer))
+
+(defun previous-error-no-select (&optional n)
+ "Move point to the previous error in the next-error buffer and highlight match.
+Prefix arg N says how many error messages to move backwards (or
+forwards, if negative).
+Finds and highlights the source line like \\[previous-error], but does not
+select the source buffer."
+ (interactive "p")
+ (next-error-no-select (- (or n 1))))
+
+;;; Internal variable for `next-error-follow-mode-post-command-hook'.
+(defvar next-error-follow-last-line nil)
+
+(define-minor-mode next-error-follow-minor-mode
+ "Minor mode for compilation, occur and diff modes.
+When turned on, cursor motion in the compilation, grep, occur or diff
+buffer causes automatic display of the corresponding source code
+location."
+ :group 'next-error :init-value " Fol"
+ (if (not next-error-follow-minor-mode)
+ (remove-hook 'post-command-hook 'next-error-follow-mode-post-command-hook t)
+ (add-hook 'post-command-hook 'next-error-follow-mode-post-command-hook nil t)
+ (make-variable-buffer-local 'next-error-follow-last-line)))
+
+;;; Used as a `post-command-hook' by `next-error-follow-mode'
+;;; for the *Compilation* *grep* and *Occur* buffers.
+(defun next-error-follow-mode-post-command-hook ()
+ (unless (equal next-error-follow-last-line (line-number-at-pos))
+ (setq next-error-follow-last-line (line-number-at-pos))
+ (condition-case nil
+ (let ((compilation-context-lines nil))
+ (setq compilation-current-error (point))
+ (next-error-no-select 0))
+ (error t))))
+
+\f
+;;;
(defun fundamental-mode ()
"Major mode not specialized for anything in particular.
Other major modes are defined by comparison with this one."
(interactive)
- (kill-all-local-variables))
+ (kill-all-local-variables)
+ (run-hooks 'after-change-major-mode-hook))
;; Making and deleting lines.
text-property `hard'.
With ARG, insert that many newlines.
Call `auto-fill-function' if the current column number is greater
-than the value of `fill-column' and ARG is `nil'."
+than the value of `fill-column' and ARG is nil."
(interactive "*P")
(barf-if-buffer-read-only)
;; Inserting a newline at the end of a line produces better redisplay in
(put-text-property from (point) 'rear-nonsticky
(cons 'hard sticky)))))
-(defun open-line (arg)
+(defun open-line (n)
"Insert a newline and leave point before it.
If there is a fill prefix and/or a left-margin, insert them on the new line
if the line would have been blank.
(loc (point))
;; Don't expand an abbrev before point.
(abbrev-mode nil))
- (newline arg)
+ (newline n)
(goto-char loc)
- (while (> arg 0)
+ (while (> n 0)
(cond ((bolp)
(if do-left-margin (indent-to (current-left-margin)))
(if do-fill-prefix (insert-and-inherit fill-prefix))))
(forward-line 1)
- (setq arg (1- arg)))
+ (setq n (1- n)))
(goto-char loc)
(end-of-line)))
-(defun split-line ()
- "Split current line, moving portion beyond point vertically down."
- (interactive "*")
+(defun split-line (&optional arg)
+ "Split current line, moving portion beyond point vertically down.
+If the current line starts with `fill-prefix', insert it on the new
+line as well. With prefix ARG, don't insert fill-prefix on new line.
+
+When called from Lisp code, ARG may be a prefix string to copy."
+ (interactive "*P")
(skip-chars-forward " \t")
- (let ((col (current-column))
- (pos (point)))
+ (let* ((col (current-column))
+ (pos (point))
+ ;; What prefix should we check for (nil means don't).
+ (prefix (cond ((stringp arg) arg)
+ (arg nil)
+ (t fill-prefix)))
+ ;; Does this line start with it?
+ (have-prfx (and prefix
+ (save-excursion
+ (beginning-of-line)
+ (looking-at (regexp-quote prefix))))))
(newline 1)
+ (if have-prfx (insert-and-inherit prefix))
(indent-to col 0)
(goto-char pos)))
In some text modes, where TAB inserts a tab, this indents to the
column specified by the function `current-left-margin'."
(interactive "*")
- (delete-horizontal-space t)
(let ((pos (point)))
;; Be careful to insert the newline before indenting the line.
;; Otherwise, the indentation might be wrong.
(newline)
(save-excursion
(goto-char pos)
- (indent-according-to-mode))
+ (indent-according-to-mode)
+ (delete-horizontal-space t))
(indent-according-to-mode)))
(defun quoted-insert (arg)
digits are interpreted as a character code. This is intended to be
useful for editing binary files."
(interactive "*p")
- (let ((char (if (or (not overwrite-mode)
- (eq overwrite-mode 'overwrite-mode-binary))
- (read-quoted-char)
- (read-char))))
+ (let* ((char (let (translation-table-for-input)
+ (if (or (not overwrite-mode)
+ (eq overwrite-mode 'overwrite-mode-binary))
+ (read-quoted-char)
+ (read-char)))))
;; Assume character codes 0240 - 0377 stand for characters in some
;; single-byte character set, and convert them to Emacs
;; characters.
(insert-and-inherit char)
(setq arg (1- arg)))))
-(defun forward-to-indentation (arg)
+(defun forward-to-indentation (&optional arg)
"Move forward ARG lines and position at first nonblank character."
(interactive "p")
- (forward-line arg)
+ (forward-line (or arg 1))
(skip-chars-forward " \t"))
-(defun backward-to-indentation (arg)
+(defun backward-to-indentation (&optional arg)
"Move backward ARG lines and position at first nonblank character."
(interactive "p")
- (forward-line (- arg))
+ (forward-line (- (or arg 1)))
(skip-chars-forward " \t"))
(defun back-to-indentation ()
"Move point to the first non-whitespace character on this line."
(interactive)
(beginning-of-line 1)
- (skip-chars-forward " \t"))
+ (skip-syntax-forward " " (line-end-position))
+ ;; Move back over chars that have whitespace syntax but have the p flag.
+ (backward-prefix-chars))
(defun fixup-whitespace ()
"Fixup white space between objects around point.
(skip-chars-backward " \t")
(constrain-to-field nil orig-pos)))))
-(defun just-one-space ()
- "Delete all spaces and tabs around point, leaving one space."
- (interactive "*")
+(defun just-one-space (&optional n)
+ "Delete all spaces and tabs around point, leaving one space (or N spaces)."
+ (interactive "*p")
(let ((orig-pos (point)))
(skip-chars-backward " \t")
(constrain-to-field nil orig-pos)
- (if (= (following-char) ? )
- (forward-char 1)
- (insert ? ))
+ (dotimes (i (or n 1))
+ (if (= (following-char) ?\ )
+ (forward-char 1)
+ (insert ?\ )))
(delete-region
(point)
(progn
\f
(defun beginning-of-buffer (&optional arg)
"Move point to the beginning of the buffer; leave mark at previous position.
-With arg N, put point N/10 of the way from the beginning.
+With \\[universal-argument] prefix, do not set mark at previous position.
+With numeric arg N, put point N/10 of the way from the beginning.
If the buffer is narrowed, this command uses the beginning and size
of the accessible part of the buffer.
Don't use this command in Lisp programs!
\(goto-char (point-min)) is faster and avoids clobbering the mark."
(interactive "P")
- (push-mark)
+ (or (consp arg)
+ (and transient-mark-mode mark-active)
+ (push-mark))
(let ((size (- (point-max) (point-min))))
- (goto-char (if arg
+ (goto-char (if (and arg (not (consp arg)))
(+ (point-min)
(if (> size 10000)
;; Avoid overflow for large buffer sizes!
(defun end-of-buffer (&optional arg)
"Move point to the end of the buffer; leave mark at previous position.
-With arg N, put point N/10 of the way from the end.
+With \\[universal-argument] prefix, do not set mark at previous position.
+With numeric arg N, put point N/10 of the way from the end.
If the buffer is narrowed, this command uses the beginning and size
of the accessible part of the buffer.
Don't use this command in Lisp programs!
\(goto-char (point-max)) is faster and avoids clobbering the mark."
(interactive "P")
- (push-mark)
+ (or (consp arg)
+ (and transient-mark-mode mark-active)
+ (push-mark))
(let ((size (- (point-max) (point-min))))
- (goto-char (if arg
+ (goto-char (if (and arg (not (consp arg)))
(- (point-max)
(if (> size 10000)
;; Avoid overflow for large buffer sizes!
;; Counting lines, one way or another.
-(defun goto-line (arg)
- "Goto line ARG, counting from line 1 at beginning of buffer."
- (interactive "NGoto line: ")
- (setq arg (prefix-numeric-value arg))
+(defun goto-line (arg &optional buffer)
+ "Goto line ARG, counting from line 1 at beginning of buffer.
+Normally, move point in the current buffer.
+With just \\[universal-argument] as argument, move point in the most recently
+displayed other buffer, and switch to it. When called from Lisp code,
+the optional argument BUFFER specifies a buffer to switch to.
+
+If there's a number in the buffer at point, it is the default for ARG."
+ (interactive
+ (if (and current-prefix-arg (not (consp current-prefix-arg)))
+ (list (prefix-numeric-value current-prefix-arg))
+ ;; Look for a default, a number in the buffer at point.
+ (let* ((default
+ (save-excursion
+ (skip-chars-backward "0-9")
+ (if (looking-at "[0-9]")
+ (buffer-substring-no-properties
+ (point)
+ (progn (skip-chars-forward "0-9")
+ (point))))))
+ ;; Decide if we're switching buffers.
+ (buffer
+ (if (consp current-prefix-arg)
+ (other-buffer (current-buffer) t)))
+ (buffer-prompt
+ (if buffer
+ (concat " in " (buffer-name buffer))
+ "")))
+ ;; Read the argument, offering that number (if any) as default.
+ (list (read-from-minibuffer (format (if default "Goto line%s (%s): "
+ "Goto line%s: ")
+ buffer-prompt
+ default)
+ nil nil t
+ 'minibuffer-history
+ default)
+ buffer))))
+ ;; Switch to the desired buffer, one way or another.
+ (if buffer
+ (let ((window (get-buffer-window buffer)))
+ (if window (select-window window)
+ (switch-to-buffer-other-window buffer))))
+ ;; Move to the specified line number in that buffer.
(save-restriction
(widen)
(goto-char 1)
(defun what-line ()
"Print the current buffer line number and narrowed line number of point."
(interactive)
- (let ((opoint (point)) start)
- (save-excursion
- (save-restriction
- (goto-char (point-min))
- (widen)
- (forward-line 0)
- (setq start (point))
- (goto-char opoint)
- (forward-line 0)
- (if (/= start 1)
- (message "line %d (narrowed line %d)"
- (1+ (count-lines 1 (point)))
- (1+ (count-lines start (point))))
- (message "Line %d" (1+ (count-lines 1 (point)))))))))
+ (let ((start (point-min))
+ (n (line-number-at-pos)))
+ (if (= start 1)
+ (message "Line %d" n)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (message "line %d (narrowed line %d)"
+ (+ n (line-number-at-pos start) -1) n))))))
(defun count-lines (start end)
"Return number of lines between START and END.
done)))
(- (buffer-size) (forward-line (buffer-size)))))))
+(defun line-number-at-pos (&optional pos)
+ "Return (narrowed) buffer line number at position POS.
+If POS is nil, use current buffer location."
+ (let ((opoint (or pos (point))) start)
+ (save-excursion
+ (goto-char (point-min))
+ (setq start (point))
+ (goto-char opoint)
+ (forward-line 0)
+ (1+ (count-lines start (point))))))
+
(defun what-cursor-position (&optional detail)
"Print info on cursor position (on screen and within buffer).
Also describe the character after point, and give its character code
byte, just \"...\" is shown.
In addition, with prefix argument, show details about that character
-in *Help* buffer. See also the command `describe-char-after'."
+in *Help* buffer. See also the command `describe-char'."
(interactive "P")
(let* ((char (following-char))
(beg (point-min))
(format "(0%o, %d, 0x%x)" char char char))))
(if detail
;; We show the detailed information about CHAR.
- (describe-char-after (point)))
+ (describe-char (point)))
(if (or (/= beg 1) (/= end (1+ total)))
(message "Char: %s %s point=%d of %d (%d%%) <%d - %d> column %d %s"
(if (< char 256)
(defvar read-expression-history nil)
(defcustom eval-expression-print-level 4
- "*Value to use for `print-level' when printing value in `eval-expression'.
+ "Value for `print-level' while printing value in `eval-expression'.
A value of nil means no limit."
:group 'lisp
:type '(choice (const :tag "No Limit" nil) integer)
:version "21.1")
(defcustom eval-expression-print-length 12
- "*Value to use for `print-length' when printing value in `eval-expression'.
+ "Value for `print-length' while printing value in `eval-expression'.
A value of nil means no limit."
:group 'lisp
:type '(choice (const :tag "No Limit" nil) integer)
:version "21.1")
(defcustom eval-expression-debug-on-error t
- "*Non-nil means set `debug-on-error' when evaluating in `eval-expression'.
+ "If non-nil set `debug-on-error' to t in `eval-expression'.
If nil, don't change the value of `debug-on-error'."
:group 'lisp
:type 'boolean
:version "21.1")
+(defun eval-expression-print-format (value)
+ "Format VALUE as a result of evaluated expression.
+Return a formatted string which is displayed in the echo area
+in addition to the value printed by prin1 in functions which
+display the result of expression evaluation."
+ (if (and (integerp value)
+ (or (not (memq this-command '(eval-last-sexp eval-print-last-sexp)))
+ (eq this-command last-command)
+ (if (boundp 'edebug-active) edebug-active)))
+ (let ((char-string
+ (if (or (if (boundp 'edebug-active) edebug-active)
+ (memq this-command '(eval-last-sexp eval-print-last-sexp)))
+ (prin1-char value))))
+ (if char-string
+ (format " (0%o, 0x%x) = %s" value value char-string)
+ (format " (0%o, 0x%x)" value value)))))
+
;; We define this, rather than making `eval' interactive,
;; for the sake of completion of names like eval-region, eval-current-buffer.
(defun eval-expression (eval-expression-arg
(let ((print-length eval-expression-print-length)
(print-level eval-expression-print-level))
- (prin1 (car values)
- (if eval-expression-insert-value (current-buffer) t))))
+ (if eval-expression-insert-value
+ (with-no-warnings
+ (let ((standard-output (current-buffer)))
+ (eval-last-sexp-print-value (car values))))
+ (prog1
+ (prin1 (car values) t)
+ (let ((str (eval-expression-print-format (car values))))
+ (if str (princ str t)))))))
(defun edit-and-eval-command (prompt command)
"Prompting with PROMPT, let user edit COMMAND and eval result.
COMMAND is a Lisp expression. Let user edit that expression in
the minibuffer, then read and evaluate the result."
- (let ((command (read-from-minibuffer prompt
- (prin1-to-string command)
- read-expression-map t
- '(command-history . 1))))
- ;; If command was added to command-history as a string,
- ;; get rid of that. We want only evaluable expressions there.
- (if (stringp (car command-history))
- (setq command-history (cdr command-history)))
+ (let ((command
+ (let ((print-level nil)
+ (minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
+ (unwind-protect
+ (read-from-minibuffer prompt
+ (prin1-to-string command)
+ read-expression-map t
+ 'command-history)
+ ;; If command was added to command-history as a string,
+ ;; get rid of that. We want only evaluable expressions there.
+ (if (stringp (car command-history))
+ (setq command-history (cdr command-history)))))))
;; If command to be redone does not match front of history,
;; add it to the history.
(let ((print-level nil)
(minibuffer-history-position arg)
(minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
- (read-from-minibuffer
- "Redo: " (prin1-to-string elt) read-expression-map t
- (cons 'command-history arg))))
+ (unwind-protect
+ (read-from-minibuffer
+ "Redo: " (prin1-to-string elt) read-expression-map t
+ (cons 'command-history arg))
- ;; If command was added to command-history as a string,
- ;; get rid of that. We want only evaluable expressions there.
- (if (stringp (car command-history))
- (setq command-history (cdr command-history)))
+ ;; If command was added to command-history as a
+ ;; string, get rid of that. We want only
+ ;; evaluable expressions there.
+ (if (stringp (car command-history))
+ (setq command-history (cdr command-history))))))
;; If command to be redone does not match front of history,
;; add it to the history.
(or (equal newcmd (car command-history))
(setq command-history (cons newcmd command-history)))
(eval newcmd))
- (ding))))
+ (if command-history
+ (error "Argument %d is beyond length of command history" arg)
+ (error "There are no previous complex commands to repeat")))))
\f
(defvar minibuffer-history nil
"Default minibuffer history list.
This is used for all minibuffer input
except when an alternate history list is specified.")
(defvar minibuffer-history-sexp-flag nil
- "Non-nil when doing history operations on the variable `command-history'.
-More generally, indicates that the history list being acted on
-contains expressions rather than strings.
-It is only valid if its value equals the current minibuffer depth,
-to handle recursive uses of the minibuffer.")
+ "Control whether history list elements are expressions or strings.
+If the value of this variable equals current minibuffer depth,
+they are expressions; otherwise they are strings.
+\(That convention is designed to do the right thing fora
+recursive uses of the minibuffer.)")
(setq minibuffer-history-variable 'minibuffer-history)
(setq minibuffer-history-position nil)
(defvar minibuffer-history-search-history nil)
nil
minibuffer-local-map
nil
- 'minibuffer-history-search-history)))
+ 'minibuffer-history-search-history
+ (car minibuffer-history-search-history))))
;; Use the last regexp specified, by default, if input is empty.
(list (if (string= regexp "")
(if minibuffer-history-search-history
nil
minibuffer-local-map
nil
- 'minibuffer-history-search-history)))
+ 'minibuffer-history-search-history
+ (car minibuffer-history-search-history))))
;; Use the last regexp specified, by default, if input is empty.
(list (if (string= regexp "")
- (setcar minibuffer-history-search-history
- (nth 1 minibuffer-history-search-history))
+ (if minibuffer-history-search-history
+ (car minibuffer-history-search-history)
+ (error "No previous history search regexp"))
regexp)
(prefix-numeric-value current-prefix-arg))))
(previous-matching-history-element regexp (- n)))
;Put this on C-x u, so we can force that rather than C-_ into startup msg
(defalias 'advertised-undo 'undo)
+(defconst undo-equiv-table (make-hash-table :test 'eq :weakness t)
+ "Table mapping redo records to the corresponding undo one.
+A redo record for undo-in-region maps to t.
+A redo record for ordinary undo maps to the following (earlier) undo.")
+
+(defvar undo-in-region nil
+ "Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.")
+
+(defvar undo-no-redo nil
+ "If t, `undo' doesn't go through redo entries.")
+
+(defvar pending-undo-list nil
+ "Within a run of consecutive undo commands, list remaining to be undone.
+t if we undid all the way to the end of it.")
+
(defun undo (&optional arg)
"Undo some previous changes.
Repeat this command to undo more changes.
A numeric argument serves as a repeat count.
In Transient Mark mode when the mark is active, only undo changes within
-the current region. Similarly, when not in Transient Mark mode, just C-u
+the current region. Similarly, when not in Transient Mark mode, just \\[universal-argument]
as an argument limits undo to changes within the current region."
(interactive "*P")
;; Make last-command indicate for the next command that this was an undo.
;; another undo command will find the undo history empty
;; and will get another error. To begin undoing the undos,
;; you must type some other command.
- (setq this-command 'undo)
(let ((modified (buffer-modified-p))
(recent-save (recent-auto-save-p)))
- (or (eq (selected-window) (minibuffer-window))
- (message "Undo!"))
- (unless (eq last-command 'undo)
- (if (if transient-mark-mode mark-active (and arg (not (numberp arg))))
+ ;; If we get an error in undo-start,
+ ;; the next command should not be a "consecutive undo".
+ ;; So set `this-command' to something other than `undo'.
+ (setq this-command 'undo-start)
+
+ (unless (and (eq last-command 'undo)
+ (or (eq pending-undo-list t)
+ ;; If something (a timer or filter?) changed the buffer
+ ;; since the previous command, don't continue the undo seq.
+ (let ((list buffer-undo-list))
+ (while (eq (car list) nil)
+ (setq list (cdr list)))
+ ;; If the last undo record made was made by undo
+ ;; it shows nothing else happened in between.
+ (gethash list undo-equiv-table))))
+ (setq undo-in-region
+ (if transient-mark-mode mark-active (and arg (not (numberp arg)))))
+ (if undo-in-region
(undo-start (region-beginning) (region-end))
(undo-start))
;; get rid of initial undo boundary
(undo-more 1))
+ ;; If we got this far, the next command should be a consecutive undo.
+ (setq this-command 'undo)
+ ;; Check to see whether we're hitting a redo record, and if
+ ;; so, ask the user whether she wants to skip the redo/undo pair.
+ (let ((equiv (gethash pending-undo-list undo-equiv-table)))
+ (or (eq (selected-window) (minibuffer-window))
+ (message (if undo-in-region
+ (if equiv "Redo in region!" "Undo in region!")
+ (if equiv "Redo!" "Undo!"))))
+ (when (and (consp equiv) undo-no-redo)
+ ;; The equiv entry might point to another redo record if we have done
+ ;; undo-redo-undo-redo-... so skip to the very last equiv.
+ (while (let ((next (gethash equiv undo-equiv-table)))
+ (if next (setq equiv next))))
+ (setq pending-undo-list equiv)))
(undo-more
(if (or transient-mark-mode (numberp arg))
(prefix-numeric-value arg)
1))
+ ;; Record the fact that the just-generated undo records come from an
+ ;; undo operation--that is, they are redo records.
+ ;; In the ordinary case (not within a region), map the redo
+ ;; record to the following undos.
+ ;; I don't know how to do that in the undo-in-region case.
+ (puthash buffer-undo-list
+ (if undo-in-region t pending-undo-list)
+ undo-equiv-table)
;; Don't specify a position in the undo record for the undo command.
;; Instead, undoing this should move point to where the change is.
(let ((tail buffer-undo-list)
(while (car tail)
(when (integerp (car tail))
(let ((pos (car tail)))
- (if (null prev)
- (setq buffer-undo-list (cdr tail))
- (setcdr prev (cdr tail)))
+ (if prev
+ (setcdr prev (cdr tail))
+ (setq buffer-undo-list (cdr tail)))
(setq tail (cdr tail))
(while (car tail)
(if (eq pos (car tail))
(setq tail (cdr tail)))
(setq tail nil)))
(setq prev tail tail (cdr tail))))
-
+ ;; Record what the current undo list says,
+ ;; so the next command can tell if the buffer was modified in between.
(and modified (not (buffer-modified-p))
(delete-auto-save-file-if-necessary recent-save))))
-(defvar pending-undo-list nil
- "Within a run of consecutive undo commands, list remaining to be undone.")
+(defun buffer-disable-undo (&optional buffer)
+ "Make BUFFER stop keeping undo information.
+No argument or nil as argument means do this for the current buffer."
+ (interactive)
+ (with-current-buffer (if buffer (get-buffer buffer) (current-buffer))
+ (setq buffer-undo-list t)))
+
+(defun undo-only (&optional arg)
+ "Undo some previous changes.
+Repeat this command to undo more changes.
+A numeric argument serves as a repeat count.
+Contrary to `undo', this will not redo a previous undo."
+ (interactive "*p")
+ (let ((undo-no-redo t)) (undo arg)))
(defvar undo-in-progress nil
"Non-nil while performing an undo.
"Undo back N undo-boundaries beyond what was already undone recently.
Call `undo-start' to get ready to undo recent changes,
then call `undo-more' one or more times to undo them."
- (or pending-undo-list
- (error "No further undo information"))
+ (or (listp pending-undo-list)
+ (error (format "No further undo information%s"
+ (if (and transient-mark-mode mark-active)
+ " for region" ""))))
(let ((undo-in-progress t))
- (setq pending-undo-list (primitive-undo count pending-undo-list))))
+ (setq pending-undo-list (primitive-undo count pending-undo-list))
+ (if (null pending-undo-list)
+ (setq pending-undo-list t))))
;; Deep copy of a list
(defun undo-copy-list (list)
If it crosses the edge, we return nil."
(cond ((integerp undo-elt)
(and (>= undo-elt start)
- (< undo-elt end)))
+ (<= undo-elt end)))
((eq undo-elt nil)
t)
((atom undo-elt)
(cons alist-elt undo-adjusted-markers)))
(and (cdr alist-elt)
(>= (cdr alist-elt) start)
- (< (cdr alist-elt) end))))
+ (<= (cdr alist-elt) end))))
((null (car undo-elt))
;; (nil PROPERTY VALUE BEG . END)
(let ((tail (nthcdr 3 undo-elt)))
(and (>= (car tail) start)
- (< (cdr tail) end))))
+ (<= (cdr tail) end))))
((integerp (car undo-elt))
;; (BEGIN . END)
(and (>= (car undo-elt) start)
- (< (cdr undo-elt) end)))))
+ (<= (cdr undo-elt) end)))))
(defun undo-elt-crosses-region (undo-elt start end)
"Test whether UNDO-ELT crosses one edge of that region START ... END.
(t
'(0 . 0)))
'(0 . 0)))
+
+(defcustom undo-ask-before-discard t
+ "If non-nil ask about discarding undo info for the current command.
+Normally, Emacs discards the undo info for the current command if
+it exceeds `undo-outer-limit'. But if you set this option
+non-nil, it asks in the echo area whether to discard the info.
+If you answer no, there a slight risk that Emacs might crash, so
+only do it if you really want to undo the command.
+
+This option is mainly intended for debugging. You have to be
+careful if you use it for other purposes. Garbage collection is
+inhibited while the question is asked, meaning that Emacs might
+leak memory. So you should make sure that you do not wait
+excessively long before answering the question."
+ :type 'boolean
+ :group 'undo
+ :version "22.1")
+
+(defvar undo-extra-outer-limit nil
+ "If non-nil, an extra level of size that's ok in an undo item.
+We don't ask the user about truncating the undo list until the
+current item gets bigger than this amount.
+
+This variable only matters if `undo-ask-before-discard' is non-nil.")
+(make-variable-buffer-local 'undo-extra-outer-limit)
+
+;; When the first undo batch in an undo list is longer than
+;; undo-outer-limit, this function gets called to warn the user that
+;; the undo info for the current command was discarded. Garbage
+;; collection is inhibited around the call, so it had better not do a
+;; lot of consing.
+(setq undo-outer-limit-function 'undo-outer-limit-truncate)
+(defun undo-outer-limit-truncate (size)
+ (if undo-ask-before-discard
+ (when (or (null undo-extra-outer-limit)
+ (> size undo-extra-outer-limit))
+ ;; Don't ask the question again unless it gets even bigger.
+ ;; This applies, in particular, if the user quits from the question.
+ ;; Such a quit quits out of GC, but something else will call GC
+ ;; again momentarily. It will call this function again,
+ ;; but we don't want to ask the question again.
+ (setq undo-extra-outer-limit (+ size 50000))
+ (if (let (use-dialog-box track-mouse executing-kbd-macro )
+ (yes-or-no-p (format "Buffer %s undo info is %d bytes long; discard it? "
+ (buffer-name) size)))
+ (progn (setq buffer-undo-list nil)
+ (setq undo-extra-outer-limit nil)
+ t)
+ nil))
+ (display-warning '(undo discard-info)
+ (concat
+ (format "Buffer %s undo info was %d bytes long.\n"
+ (buffer-name) size)
+ "The undo info was discarded because it exceeded \
+`undo-outer-limit'.
+
+This is normal if you executed a command that made a huge change
+to the buffer. In that case, to prevent similar problems in the
+future, set `undo-outer-limit' to a value that is large enough to
+cover the maximum size of normal changes you expect a single
+command to make, but not so large that it might exceed the
+maximum memory allotted to Emacs.
+
+If you did not execute any such command, the situation is
+probably due to a bug and you should report it.
+
+You can disable the popping up of this buffer by adding the entry
+\(undo discard-info) to the user option `warning-suppress-types'.\n")
+ :warning)
+ (setq buffer-undo-list nil)
+ t))
\f
(defvar shell-command-history nil
"History list for some commands that read shell commands.")
(defvar shell-command-default-error-buffer nil
"*Buffer name for `shell-command' and `shell-command-on-region' error output.
-This buffer is used when `shell-command' or 'shell-command-on-region'
+This buffer is used when `shell-command' or `shell-command-on-region'
is run interactively. A value of nil means that output to stderr and
stdout will be intermixed in the output stream.")
;; Output goes in a separate buffer.
;; Preserve the match data in case called from a program.
(save-match-data
- (if (string-match "[ \t]*&[ \t]*$" command)
+ (if (string-match "[ \t]*&[ \t]*\\'" command)
;; Command ending with ampersand means asynchronous.
(let ((buffer (get-buffer-create
(or output-buffer "*Async Shell Command*")))
(if (yes-or-no-p "A command is running. Kill it? ")
(kill-process proc)
(error "Shell command in progress")))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(setq buffer-read-only nil)
(erase-buffer)
(display-buffer buffer)
(if (= (buffer-size) 0)
0
(count-lines (point-min) (point-max)))))
- (cond ((or (<= lines 1)
- (<= lines
- (if resize-mini-windows
- (cond ((floatp max-mini-window-height)
- (* (frame-height)
- max-mini-window-height))
- ((integerp max-mini-window-height)
- max-mini-window-height)
- (t
- 1))
- 1)))
+ (cond ((= lines 0))
+ ((and (or (<= lines 1)
+ (<= lines
+ (if resize-mini-windows
+ (cond ((floatp max-mini-window-height)
+ (* (frame-height)
+ max-mini-window-height))
+ ((integerp max-mini-window-height)
+ max-mini-window-height)
+ (t
+ 1))
+ 1)))
+ ;; Don't use the echo area if the output buffer is
+ ;; already dispayed in the selected frame.
+ (not (get-buffer-window (current-buffer))))
;; Echo area
(goto-char (point-max))
(when (bolp)
(defun shell-command-on-region (start end command
&optional output-buffer replace
- error-buffer)
+ error-buffer display-error-buffer)
"Execute string COMMAND in inferior shell with region as input.
Normally display output (if any) in temp buffer `*Shell Command Output*';
Prefix arg means replace the region with it. Return the exit code of
`buffer-file-coding-system'. If the output is going to replace the region,
then it is decoded from that same coding system.
-The noninteractive arguments are START, END, COMMAND, OUTPUT-BUFFER,
-REPLACE, ERROR-BUFFER. Noninteractive callers can specify coding
-systems by binding `coding-system-for-read' and
-`coding-system-for-write'.
+The noninteractive arguments are START, END, COMMAND,
+OUTPUT-BUFFER, REPLACE, ERROR-BUFFER, and DISPLAY-ERROR-BUFFER.
+Noninteractive callers can specify coding systems by binding
+`coding-system-for-read' and `coding-system-for-write'.
If the command generates output, the output may be displayed
in the echo area or in a buffer.
If optional sixth argument ERROR-BUFFER is non-nil, it is a buffer
or buffer name to which to direct the command's standard error output.
If it is nil, error output is mingled with regular output.
+If DISPLAY-ERROR-BUFFER is non-nil, display the error buffer if there
+were any errors. (This is always t, interactively.)
In an interactive call, the variable `shell-command-default-error-buffer'
specifies the value of ERROR-BUFFER."
(interactive (let (string)
string
current-prefix-arg
current-prefix-arg
- shell-command-default-error-buffer)))
+ shell-command-default-error-buffer
+ t)))
(let ((error-file
(if error-buffer
(make-temp-file
;; No prefix argument: put the output in a temp buffer,
;; replacing its entire contents.
(let ((buffer (get-buffer-create
- (or output-buffer "*Shell Command Output*")))
- (success nil))
+ (or output-buffer "*Shell Command Output*"))))
(unwind-protect
(if (eq buffer (current-buffer))
;; If the input is the same buffer as the output,
(list buffer error-file)
buffer)
nil shell-command-switch command)))
- (setq success (and exit-status (equal 0 exit-status)))
;; Report the output.
(with-current-buffer buffer
- (setq mode-line-process
- (if (not success)
- (concat (format " - Exit [%d]" exit-status)))))
+ (setq mode-line-process
+ (cond ((null exit-status)
+ " - Error")
+ ((stringp exit-status)
+ (format " - Signal [%s]" exit-status))
+ ((not (equal 0 exit-status))
+ (format " - Exit [%d]" exit-status)))))
(if (with-current-buffer buffer (> (point-max) (point-min)))
;; There's some output, display it
(display-message-or-buffer buffer)
(< 0 (nth 7 (file-attributes error-file))))
"some error output"
"no output")))
- (if (equal 0 exit-status)
- (message "(Shell command succeeded with %s)"
- output)
- (message "(Shell command failed with code %d and %s)"
- exit-status output)))
+ (cond ((null exit-status)
+ (message "(Shell command failed with error)"))
+ ((equal 0 exit-status)
+ (message "(Shell command succeeded with %s)"
+ output))
+ ((stringp exit-status)
+ (message "(Shell command killed by signal %s)"
+ exit-status))
+ (t
+ (message "(Shell command failed with code %d and %s)"
+ exit-status output))))
;; Don't kill: there might be useful info in the undo-log.
;; (kill-buffer buffer)
))))
(format-insert-file error-file nil)
;; Put point after the inserted errors.
(goto-char (- (point-max) pos-from-end)))
- (display-buffer (current-buffer))))
+ (and display-error-buffer
+ (display-buffer (current-buffer)))))
(delete-file error-file))
exit-status))
(with-current-buffer
standard-output
(call-process shell-file-name nil t nil shell-command-switch command))))
+
+(defun process-file (program &optional infile buffer display &rest args)
+ "Process files synchronously in a separate process.
+Similar to `call-process', but may invoke a file handler based on
+`default-directory'. The current working directory of the
+subprocess is `default-directory'.
+
+File names in INFILE and BUFFER are handled normally, but file
+names in ARGS should be relative to `default-directory', as they
+are passed to the process verbatim. \(This is a difference to
+`call-process' which does not support file handlers for INFILE
+and BUFFER.\)
+
+Some file handlers might not support all variants, for example
+they might behave as if DISPLAY was nil, regardless of the actual
+value passed."
+ (let ((fh (find-file-name-handler default-directory 'process-file))
+ lc stderr-file)
+ (unwind-protect
+ (if fh (apply fh 'process-file program infile buffer display args)
+ (when infile (setq lc (file-local-copy infile)))
+ (setq stderr-file (when (and (consp buffer) (stringp (cadr buffer)))
+ (make-temp-file "emacs")))
+ (prog1
+ (apply 'call-process program
+ (or lc infile)
+ (if stderr-file (list (car buffer) stderr-file) buffer)
+ display args)
+ (when stderr-file (copy-file stderr-file (cadr buffer)))))
+ (when stderr-file (delete-file stderr-file))
+ (when lc (delete-file lc)))))
+
+
\f
(defvar universal-argument-map
(let ((map (make-sparse-keymap)))
`universal-argument-other-key' uses this to discard those events
from (this-command-keys), and reread only the final command.")
+(defvar overriding-map-is-bound nil
+ "Non-nil when `overriding-terminal-local-map' is `universal-argument-map'.")
+
+(defvar saved-overriding-map nil
+ "The saved value of `overriding-terminal-local-map'.
+That variable gets restored to this value on exiting \"universal
+argument mode\".")
+
+(defun ensure-overriding-map-is-bound ()
+ "Check `overriding-terminal-local-map' is `universal-argument-map'."
+ (unless overriding-map-is-bound
+ (setq saved-overriding-map overriding-terminal-local-map)
+ (setq overriding-terminal-local-map universal-argument-map)
+ (setq overriding-map-is-bound t)))
+
+(defun restore-overriding-map ()
+ "Restore `overriding-terminal-local-map' to its saved value."
+ (setq overriding-terminal-local-map saved-overriding-map)
+ (setq overriding-map-is-bound nil))
+
(defun universal-argument ()
"Begin a numeric argument for the following command.
Digits or minus sign following \\[universal-argument] make up the numeric argument.
(interactive)
(setq prefix-arg (list 4))
(setq universal-argument-num-events (length (this-command-keys)))
- (setq overriding-terminal-local-map universal-argument-map))
+ (ensure-overriding-map-is-bound))
;; A subsequent C-u means to multiply the factor by 4 if we've typed
;; nothing but C-u's; otherwise it means to terminate the prefix arg.
(if (eq arg '-)
(setq prefix-arg (list -4))
(setq prefix-arg arg)
- (setq overriding-terminal-local-map nil)))
+ (restore-overriding-map)))
(setq universal-argument-num-events (length (this-command-keys))))
(defun negative-argument (arg)
(t
(setq prefix-arg '-)))
(setq universal-argument-num-events (length (this-command-keys)))
- (setq overriding-terminal-local-map universal-argument-map))
+ (ensure-overriding-map-is-bound))
(defun digit-argument (arg)
"Part of the numeric argument for the next command.
(t
(setq prefix-arg digit))))
(setq universal-argument-num-events (length (this-command-keys)))
- (setq overriding-terminal-local-map universal-argument-map))
+ (ensure-overriding-map-is-bound))
;; For backward compatibility, minus with no modifiers is an ordinary
;; command if digits have already been entered.
(append (nthcdr universal-argument-num-events keylist)
unread-command-events)))
(reset-this-command-lengths)
- (setq overriding-terminal-local-map nil))
+ (restore-overriding-map))
\f
+(defvar buffer-substring-filters nil
+ "List of filter functions for `filter-buffer-substring'.
+Each function must accept a single argument, a string, and return
+a string. The buffer substring is passed to the first function
+in the list, and the return value of each function is passed to
+the next. The return value of the last function is used as the
+return value of `filter-buffer-substring'.
+
+If this variable is nil, no filtering is performed.")
+
+(defun filter-buffer-substring (beg end &optional delete)
+ "Return the buffer substring between BEG and END, after filtering.
+The buffer substring is passed through each of the filter
+functions in `buffer-substring-filters', and the value from the
+last filter function is returned. If `buffer-substring-filters'
+is nil, the buffer substring is returned unaltered.
+
+If DELETE is non-nil, the text between BEG and END is deleted
+from the buffer.
+
+Point is temporarily set to BEG before calling
+`buffer-substring-filters', in case the functions need to know
+where the text came from.
+
+This function should be used instead of `buffer-substring' or
+`delete-and-extract-region' when you want to allow filtering to
+take place. For example, major or minor modes can use
+`buffer-substring-filters' to extract characters that are special
+to a buffer, and should not be copied into other buffers."
+ (save-excursion
+ (goto-char beg)
+ (let ((string (if delete (delete-and-extract-region beg end)
+ (buffer-substring beg end))))
+ (dolist (filter buffer-substring-filters string)
+ (setq string (funcall filter string))))))
+
;;;; Window system cut and paste hooks.
(defvar interprogram-cut-function nil
The function takes one or two arguments.
The first argument, TEXT, is a string containing
the text which should be made available.
-The second, PUSH, if non-nil means this is a \"new\" kill;
-nil means appending to an \"old\" kill.")
+The second, optional, argument PUSH, has the same meaning as the
+similar argument to `x-set-cut-buffer', which see.")
(defvar interprogram-paste-function nil
"Function to call to get text cut from other programs.
The function should be called with no arguments. If the function
returns nil, then no other program has provided such text, and the top
of the Emacs kill ring should be used. If the function returns a
-string, that string should be put in the kill ring as the latest kill.
+string, then the caller of the function \(usually `current-kill')
+should put this string in the kill ring as the latest kill.
Note that the function should return a string only if a program other
than Emacs has provided a string for pasting; if Emacs provided the
(defvar kill-ring-yank-pointer nil
"The tail of the kill ring whose car is the last thing yanked.")
-(defun kill-new (string &optional replace)
+(defun kill-new (string &optional replace yank-handler)
"Make STRING the latest kill in the kill ring.
Set `kill-ring-yank-pointer' to point to it.
If `interprogram-cut-function' is non-nil, apply it to STRING.
Optional second argument REPLACE non-nil means that STRING will replace
-the front of the kill ring, rather than being added to the list."
- (and (fboundp 'menu-bar-update-yank-menu)
- (menu-bar-update-yank-menu string (and replace (car kill-ring))))
+the front of the kill ring, rather than being added to the list.
+
+Optional third arguments YANK-HANDLER controls how the STRING is later
+inserted into a buffer; see `insert-for-yank' for details.
+When a yank handler is specified, STRING must be non-empty (the yank
+handler, if non-nil, is stored as a `yank-handler' text property on STRING).
+
+When the yank handler has a non-nil PARAM element, the original STRING
+argument is not used by `insert-for-yank'. However, since Lisp code
+may access and use elements from the kill-ring directly, the STRING
+argument should still be a \"useful\" string for such uses."
+ (if (> (length string) 0)
+ (if yank-handler
+ (put-text-property 0 (length string)
+ 'yank-handler yank-handler string))
+ (if yank-handler
+ (signal 'args-out-of-range
+ (list string "yank-handler specified for empty string"))))
+ (if (fboundp 'menu-bar-update-yank-menu)
+ (menu-bar-update-yank-menu string (and replace (car kill-ring))))
(if (and replace kill-ring)
(setcar kill-ring string)
(setq kill-ring (cons string kill-ring))
(if interprogram-cut-function
(funcall interprogram-cut-function string (not replace))))
-(defun kill-append (string before-p)
+(defun kill-append (string before-p &optional yank-handler)
"Append STRING to the end of the latest kill in the kill ring.
If BEFORE-P is non-nil, prepend STRING to the kill.
-If `interprogram-cut-function' is set, pass the resulting kill to
-it."
- (kill-new (if before-p
- (concat string (car kill-ring))
- (concat (car kill-ring) string))
- t))
+Optional third argument YANK-HANDLER, if non-nil, specifies the
+yank-handler text property to be set on the combined kill ring
+string. If the specified yank-handler arg differs from the
+yank-handler property of the latest kill string, this function
+adds the combined string to the kill ring as a new element,
+instead of replacing the last kill with it.
+If `interprogram-cut-function' is set, pass the resulting kill to it."
+ (let* ((cur (car kill-ring)))
+ (kill-new (if before-p (concat string cur) (concat cur string))
+ (or (= (length cur) 0)
+ (equal yank-handler (get-text-property 0 'yank-handler cur)))
+ yank-handler)))
(defun current-kill (n &optional do-not-move)
"Rotate the yanking point by N places, and then return that kill.
'(text-read-only buffer-read-only error))
(put 'text-read-only 'error-message "Text is read-only")
-(defun kill-region (beg end)
+(defun kill-region (beg end &optional yank-handler)
"Kill between point and mark.
The text is deleted but saved in the kill ring.
The command \\[yank] can retrieve it from there.
you can use the killing commands to copy text from a read-only buffer.
This is the primitive for programs to kill text (as opposed to deleting it).
-Supply two arguments, character numbers indicating the stretch of text
+Supply two arguments, character positions indicating the stretch of text
to be killed.
Any command that calls this function is a \"kill command\".
If the previous command was also a kill command,
the text killed this time appends to the text killed last time
-to make one entry in the kill ring."
+to make one entry in the kill ring.
+
+In Lisp code, optional third arg YANK-HANDLER, if non-nil,
+specifies the yank-handler text property to be set on the killed
+text. See `insert-for-yank'."
(interactive "r")
(condition-case nil
- (let ((string (delete-and-extract-region beg end)))
+ (let ((string (filter-buffer-substring beg end t)))
(when string ;STRING is nil if BEG = END
;; Add that string to the kill ring, one way or another.
(if (eq last-command 'kill-region)
- (kill-append string (< end beg))
- (kill-new string)))
- (setq this-command 'kill-region))
+ (kill-append string (< end beg) yank-handler)
+ (kill-new string nil yank-handler)))
+ (when (or string (eq last-command 'kill-region))
+ (setq this-command 'kill-region))
+ nil)
((buffer-read-only text-read-only)
;; The code above failed because the buffer, or some of the characters
;; in the region, are read-only.
(setq this-command 'kill-region)
;; This should barf, if appropriate, and give us the correct error.
(if kill-read-only-ok
- (message "Read only text copied to kill ring")
+ (progn (message "Read only text copied to kill ring") nil)
;; Signal an error if the buffer is read-only.
(barf-if-buffer-read-only)
;; If the buffer isn't read-only, the text is.
system cut and paste."
(interactive "r")
(if (eq last-command 'kill-region)
- (kill-append (buffer-substring beg end) (< end beg))
- (kill-new (buffer-substring beg end)))
+ (kill-append (filter-buffer-substring beg end) (< end beg))
+ (kill-new (filter-buffer-substring beg end)))
(if transient-mark-mode
(setq deactivate-mark t))
nil)
visual feedback indicating the extent of the region being copied."
(interactive "r")
(copy-region-as-kill beg end)
+ ;; This use of interactive-p is correct
+ ;; because the code it controls just gives the user visual feedback.
(if (interactive-p)
(let ((other-end (if (= (point) beg) end beg))
(opoint (point))
;; look like a C-g typed as a command.
(inhibit-quit t))
(if (pos-visible-in-window-p other-end (selected-window))
- (unless transient-mark-mode
+ (unless (and transient-mark-mode
+ (face-background 'region))
;; Swap point and mark.
(set-marker (mark-marker) (point) (current-buffer))
(goto-char other-end)
- (sit-for 1)
+ (sit-for blink-matching-delay)
;; Swap back.
(set-marker (mark-marker) other-end (current-buffer))
(goto-char opoint)
(setq this-command 'kill-region)
(message "If the next command is a kill, it will append"))
(setq last-command 'kill-region)))
-
+\f
;; Yanking.
-(defun yank-pop (arg)
+;; This is actually used in subr.el but defcustom does not work there.
+(defcustom yank-excluded-properties
+ '(read-only invisible intangible field mouse-face help-echo local-map keymap
+ yank-handler follow-link)
+ "*Text properties to discard when yanking.
+The value should be a list of text properties to discard or t,
+which means to discard all text properties."
+ :type '(choice (const :tag "All" t) (repeat symbol))
+ :group 'killing
+ :version "22.1")
+
+(defvar yank-window-start nil)
+(defvar yank-undo-function nil
+ "If non-nil, function used by `yank-pop' to delete last stretch of yanked text.
+Function is called with two parameters, START and END corresponding to
+the value of the mark and point; it is guaranteed that START <= END.
+Normally set from the UNDO element of a yank-handler; see `insert-for-yank'.")
+
+(defun yank-pop (&optional arg)
"Replace just-yanked stretch of killed text with a different stretch.
This command is allowed only immediately after a `yank' or a `yank-pop'.
At such a time, the region contains a stretch of reinserted
If N is negative, this is a more recent kill.
The sequence of kills wraps around, so that after the oldest one
-comes the newest one."
+comes the newest one.
+
+When this command inserts killed text into the buffer, it honors
+`yank-excluded-properties' and `yank-handler' as described in the
+doc string for `insert-for-yank-1', which see."
(interactive "*p")
(if (not (eq last-command 'yank))
(error "Previous command was not a yank"))
(setq this-command 'yank)
+ (unless arg (setq arg 1))
(let ((inhibit-read-only t)
(before (< (point) (mark t))))
- (delete-region (point) (mark t))
+ (if before
+ (funcall (or yank-undo-function 'delete-region) (point) (mark t))
+ (funcall (or yank-undo-function 'delete-region) (mark t) (point)))
+ (setq yank-undo-function nil)
(set-marker (mark-marker) (point) (current-buffer))
- (let ((opoint (point)))
- (insert (current-kill arg))
- (let ((inhibit-read-only t))
- (remove-text-properties opoint (point) '(read-only nil))))
+ (insert-for-yank (current-kill arg))
+ ;; Set the window start back where it was in the yank command,
+ ;; if possible.
+ (set-window-start (selected-window) yank-window-start t)
(if before
;; This is like exchange-point-and-mark, but doesn't activate the mark.
;; It is cleaner to avoid activation, even though the command
"Reinsert the last stretch of killed text.
More precisely, reinsert the stretch of killed text most recently
killed OR yanked. Put point at end, and set mark at beginning.
-With just C-u as argument, same but put point at beginning (and mark at end).
+With just \\[universal-argument] as argument, same but put point at beginning (and mark at end).
With argument N, reinsert the Nth most recently killed stretch of killed
text.
+
+When this command inserts killed text into the buffer, it honors
+`yank-excluded-properties' and `yank-handler' as described in the
+doc string for `insert-for-yank-1', which see.
+
See also the command \\[yank-pop]."
(interactive "*P")
+ (setq yank-window-start (window-start))
;; If we don't get all the way thru, make last-command indicate that
;; for the following command.
(setq this-command t)
(push-mark (point))
- (let ((opoint (point)))
- (insert (current-kill (cond
- ((listp arg) 0)
- ((eq arg '-) -1)
- (t (1- arg)))))
- (let ((inhibit-read-only t))
- ;; Clear `field' property for the sake of copying from the
- ;; minibuffer prompt or a *shell* prompt.
- (remove-text-properties opoint (point) '(read-only nil field nil))))
+ (insert-for-yank (current-kill (cond
+ ((listp arg) 0)
+ ((eq arg '-) -2)
+ (t (1- arg)))))
(if (consp arg)
;; This is like exchange-point-and-mark, but doesn't activate the mark.
;; It is cleaner to avoid activation, even though the command
(goto-char (prog1 (mark t)
(set-marker (mark-marker) (point) (current-buffer)))))
;; If we do get all the way thru, make this-command indicate that.
- (setq this-command 'yank)
+ (if (eq this-command t)
+ (setq this-command 'yank))
nil)
(defun rotate-yank-pointer (arg)
(let ((col (current-column)))
(forward-char -1)
(setq col (- col (current-column)))
- (insert-char ?\ col)
+ (insert-char ?\ col)
(delete-char 1)))
(forward-char -1)
(setq count (1- count))))))
If the buffer is read-only, Emacs will beep and refrain from deleting
the line, but put the line in the kill ring anyway. This means that
-you can use this command to copy text from a read-only buffer."
+you can use this command to copy text from a read-only buffer.
+\(If the variable `kill-read-only-ok' is non-nil, then this won't
+even beep.)"
(interactive "P")
(kill-region (point)
;; It is better to move point to the other end of the kill
(forward-visible-line (prefix-numeric-value arg))
(if (eobp)
(signal 'end-of-buffer nil))
- (if (or (looking-at "[ \t]*$") (and kill-whole-line (bolp)))
- (forward-visible-line 1)
- (end-of-visible-line)))
+ (let ((end
+ (save-excursion
+ (end-of-visible-line) (point))))
+ (if (or (save-excursion
+ ;; If trailing whitespace is visible,
+ ;; don't treat it as nothing.
+ (unless show-trailing-whitespace
+ (skip-chars-forward " \t" end))
+ (= (point) end))
+ (and kill-whole-line (bolp)))
+ (forward-visible-line 1)
+ (goto-char end))))
(point))))
+(defun kill-whole-line (&optional arg)
+ "Kill current line.
+With prefix arg, kill that many lines starting from the current line.
+If arg is negative, kill backward. Also kill the preceding newline.
+\(This is meant to make C-x z work well with negative arguments.\)
+If arg is zero, kill current line but exclude the trailing newline."
+ (interactive "p")
+ (if (and (> arg 0) (eobp) (save-excursion (forward-visible-line 0) (eobp)))
+ (signal 'end-of-buffer nil))
+ (if (and (< arg 0) (bobp) (save-excursion (end-of-visible-line) (bobp)))
+ (signal 'beginning-of-buffer nil))
+ (unless (eq last-command 'kill-region)
+ (kill-new "")
+ (setq last-command 'kill-region))
+ (cond ((zerop arg)
+ ;; We need to kill in two steps, because the previous command
+ ;; could have been a kill command, in which case the text
+ ;; before point needs to be prepended to the current kill
+ ;; ring entry and the text after point appended. Also, we
+ ;; need to use save-excursion to avoid copying the same text
+ ;; twice to the kill ring in read-only buffers.
+ (save-excursion
+ (kill-region (point) (progn (forward-visible-line 0) (point))))
+ (kill-region (point) (progn (end-of-visible-line) (point))))
+ ((< arg 0)
+ (save-excursion
+ (kill-region (point) (progn (end-of-visible-line) (point))))
+ (kill-region (point)
+ (progn (forward-visible-line (1+ arg))
+ (unless (bobp) (backward-char))
+ (point))))
+ (t
+ (save-excursion
+ (kill-region (point) (progn (forward-visible-line 0) (point))))
+ (kill-region (point)
+ (progn (forward-visible-line arg) (point))))))
+
(defun forward-visible-line (arg)
"Move forward by ARG lines, ignoring currently invisible newlines only.
If ARG is negative, move backward -ARG lines.
If ARG is zero, move to the beginning of the current line."
(condition-case nil
(if (> arg 0)
- (while (> arg 0)
- (or (zerop (forward-line 1))
- (signal 'end-of-buffer nil))
- ;; If the following character is currently invisible,
- ;; skip all characters with that same `invisible' property value,
- ;; then find the next newline.
- (while (and (not (eobp))
- (let ((prop
- (get-char-property (point) 'invisible)))
- (if (eq buffer-invisibility-spec t)
- prop
- (or (memq prop buffer-invisibility-spec)
- (assq prop buffer-invisibility-spec)))))
- (goto-char
- (if (get-text-property (point) 'invisible)
- (or (next-single-property-change (point) 'invisible)
- (point-max))
- (next-overlay-change (point))))
+ (progn
+ (while (> arg 0)
(or (zerop (forward-line 1))
- (signal 'end-of-buffer nil)))
- (setq arg (1- arg)))
+ (signal 'end-of-buffer nil))
+ ;; If the newline we just skipped is invisible,
+ ;; don't count it.
+ (let ((prop
+ (get-char-property (1- (point)) 'invisible)))
+ (if (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))
+ (setq arg (1+ arg))))
+ (setq arg (1- arg)))
+ ;; If invisible text follows, and it is a number of complete lines,
+ ;; skip it.
+ (let ((opoint (point)))
+ (while (and (not (eobp))
+ (let ((prop
+ (get-char-property (point) 'invisible)))
+ (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))))
+ (goto-char
+ (if (get-text-property (point) 'invisible)
+ (or (next-single-property-change (point) 'invisible)
+ (point-max))
+ (next-overlay-change (point)))))
+ (unless (bolp)
+ (goto-char opoint))))
(let ((first t))
- (while (or first (< arg 0))
- (if (zerop arg)
+ (while (or first (<= arg 0))
+ (if first
(beginning-of-line)
(or (zerop (forward-line -1))
(signal 'beginning-of-buffer nil)))
+ ;; If the newline we just moved to is invisible,
+ ;; don't count it.
+ (unless (bobp)
+ (let ((prop
+ (get-char-property (1- (point)) 'invisible)))
+ (unless (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))
+ (setq arg (1+ arg)))))
+ (setq first nil))
+ ;; If invisible text follows, and it is a number of complete lines,
+ ;; skip it.
+ (let ((opoint (point)))
(while (and (not (bobp))
(let ((prop
(get-char-property (1- (point)) 'invisible)))
(if (get-text-property (1- (point)) 'invisible)
(or (previous-single-property-change (point) 'invisible)
(point-min))
- (previous-overlay-change (point))))
- (or (zerop (forward-line -1))
- (signal 'beginning-of-buffer nil)))
- (setq first nil)
- (setq arg (1+ arg)))))
+ (previous-overlay-change (point)))))
+ (unless (bolp)
+ (goto-char opoint)))))
((beginning-of-buffer end-of-buffer)
nil)))
;; skip all characters with that same `invisible' property value,
;; then find the next newline.
(while (and (not (eobp))
- (let ((prop
- (get-char-property (point) 'invisible)))
- (if (eq buffer-invisibility-spec t)
- prop
- (or (memq prop buffer-invisibility-spec)
- (assq prop buffer-invisibility-spec)))))
+ (save-excursion
+ (skip-chars-forward "^\n")
+ (let ((prop
+ (get-char-property (point) 'invisible)))
+ (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec))))))
+ (skip-chars-forward "^\n")
(if (get-text-property (point) 'invisible)
(goto-char (next-single-property-change (point) 'invisible))
(goto-char (next-overlay-change (point))))
BUFFER may be a buffer or a buffer name.
This function is meant for the user to run interactively.
-Don't call it from programs!"
+Don't call it from programs: use `insert-buffer-substring' instead!"
(interactive
(list
(progn
(other-buffer (current-buffer))
(window-buffer (next-window (selected-window))))
t))))
- (or (bufferp buffer)
- (setq buffer (get-buffer buffer)))
- (let (start end newmark)
- (save-excursion
- (save-excursion
- (set-buffer buffer)
- (setq start (point-min) end (point-max)))
- (insert-buffer-substring buffer start end)
- (setq newmark (point)))
- (push-mark newmark))
+ (push-mark
+ (save-excursion
+ (insert-buffer-substring (get-buffer buffer))
+ (point)))
nil)
(defun append-to-buffer (buffer start end)
(put 'mark-inactive 'error-conditions '(mark-inactive error))
(put 'mark-inactive 'error-message "The mark is not active now")
+(defvar activate-mark-hook nil
+ "Hook run when the mark becomes active.
+It is also run at the end of a command, if the mark is active and
+it is possible that the region may have changed")
+
+(defvar deactivate-mark-hook nil
+ "Hook run when the mark becomes inactive.")
+
(defun mark (&optional force)
"Return this buffer's mark value as integer; error if mark inactive.
If optional argument FORCE is non-nil, access the mark value
"Deactivate the mark by setting `mark-active' to nil.
\(That makes a difference only in Transient Mark mode.)
Also runs the hook `deactivate-mark-hook'."
- (if transient-mark-mode
- (progn
- (setq mark-active nil)
- (run-hooks 'deactivate-mark-hook))))
+ (cond
+ ((eq transient-mark-mode 'lambda)
+ (setq transient-mark-mode nil))
+ (transient-mark-mode
+ (setq mark-active nil)
+ (run-hooks 'deactivate-mark-hook))))
(defun set-mark (pos)
"Set this buffer's mark to POS. Don't use this function!
mark position to be lost.
Normally, when a new mark is set, the old one should go on the stack.
-This is why most applications should use push-mark, not set-mark.
+This is why most applications should use `push-mark', not `set-mark'.
Novice Emacs Lisp programmers often try to use the mark for the wrong
purposes. The mark saves a location for the user's convenience.
:type 'integer
:group 'editing-basics)
+(defun pop-to-mark-command ()
+ "Jump to mark, and pop a new position for mark off the ring
+\(does not affect global mark ring\)."
+ (interactive)
+ (if (null (mark t))
+ (error "No mark set in this buffer")
+ (goto-char (mark t))
+ (pop-mark)))
+
+(defun push-mark-command (arg &optional nomsg)
+ "Set mark at where point is.
+If no prefix arg and mark is already set there, just activate it.
+Display `Mark set' unless the optional second arg NOMSG is non-nil."
+ (interactive "P")
+ (let ((mark (marker-position (mark-marker))))
+ (if (or arg (null mark) (/= mark (point)))
+ (push-mark nil nomsg t)
+ (setq mark-active t)
+ (run-hooks 'activate-mark-hook)
+ (unless nomsg
+ (message "Mark activated")))))
+
(defun set-mark-command (arg)
"Set mark at where point is, or jump to mark.
-With no prefix argument, set mark, push old mark position on local mark
-ring, and push mark on global mark ring.
-With argument, jump to mark, and pop a new position for mark off the ring
-\(does not affect global mark ring\).
+With no prefix argument, set mark, and push old mark position on local
+mark ring; also push mark on global mark ring if last mark was set in
+another buffer. Immediately repeating the command activates
+`transient-mark-mode' temporarily.
+
+With argument, e.g. \\[universal-argument] \\[set-mark-command], \
+jump to mark, and pop a new position
+for mark off the local mark ring \(this does not affect the global
+mark ring\). Use \\[pop-global-mark] to jump to a mark off the global
+mark ring \(see `pop-global-mark'\).
+
+Repeating the \\[set-mark-command] command without the prefix jumps to
+the next position off the local (or global) mark ring.
+
+With a double \\[universal-argument] prefix argument, e.g. \\[universal-argument] \
+\\[universal-argument] \\[set-mark-command], unconditionally
+set mark where point is.
Novice Emacs Lisp programmers often try to use the mark for the wrong
purposes. See the documentation of `set-mark' for more information."
(interactive "P")
- (if (null arg)
- (progn
- (push-mark nil nil t))
- (if (null (mark t))
- (error "No mark set in this buffer")
- (goto-char (mark t))
- (pop-mark))))
+ (if (eq transient-mark-mode 'lambda)
+ (setq transient-mark-mode nil))
+ (cond
+ ((and (consp arg) (> (prefix-numeric-value arg) 4))
+ (push-mark-command nil))
+ ((not (eq this-command 'set-mark-command))
+ (if arg
+ (pop-to-mark-command)
+ (push-mark-command t)))
+ ((eq last-command 'pop-to-mark-command)
+ (setq this-command 'pop-to-mark-command)
+ (pop-to-mark-command))
+ ((and (eq last-command 'pop-global-mark) (not arg))
+ (setq this-command 'pop-global-mark)
+ (pop-global-mark))
+ (arg
+ (setq this-command 'pop-to-mark-command)
+ (pop-to-mark-command))
+ ((and (eq last-command 'set-mark-command)
+ mark-active (null transient-mark-mode))
+ (setq transient-mark-mode 'lambda)
+ (message "Transient-mark-mode temporarily enabled"))
+ (t
+ (push-mark-command nil))))
(defun push-mark (&optional location nomsg activate)
"Set mark at LOCATION (point, by default) and push old mark on mark ring.
purposes. See the documentation of `set-mark' for more information.
In Transient Mark mode, this does not activate the mark."
- (if (null (mark t))
- nil
+ (unless (null (mark t))
(setq mark-ring (cons (copy-marker (mark-marker)) mark-ring))
- (if (> (length mark-ring) mark-ring-max)
- (progn
- (move-marker (car (nthcdr mark-ring-max mark-ring)) nil)
- (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil))))
+ (when (> (length mark-ring) mark-ring-max)
+ (move-marker (car (nthcdr mark-ring-max mark-ring)) nil)
+ (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil)))
(set-marker (mark-marker) (or location (point)) (current-buffer))
;; Now push the mark on the global mark ring.
(if (and global-mark-ring
;; Don't push another one.
nil
(setq global-mark-ring (cons (copy-marker (mark-marker)) global-mark-ring))
- (if (> (length global-mark-ring) global-mark-ring-max)
- (progn
- (move-marker (car (nthcdr global-mark-ring-max global-mark-ring))
- nil)
- (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil))))
+ (when (> (length global-mark-ring) global-mark-ring-max)
+ (move-marker (car (nthcdr global-mark-ring-max global-mark-ring)) nil)
+ (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil)))
(or nomsg executing-kbd-macro (> (minibuffer-depth) 0)
(message "Mark set"))
(if (or activate (not transient-mark-mode))
(defun pop-mark ()
"Pop off mark ring into the buffer's actual mark.
Does not set point. Does nothing if mark ring is empty."
- (if mark-ring
- (progn
- (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker)))))
- (set-marker (mark-marker) (+ 0 (car mark-ring)) (current-buffer))
- (deactivate-mark)
- (move-marker (car mark-ring) nil)
- (if (null (mark t)) (ding))
- (setq mark-ring (cdr mark-ring)))))
+ (when mark-ring
+ (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker)))))
+ (set-marker (mark-marker) (+ 0 (car mark-ring)) (current-buffer))
+ (move-marker (car mark-ring) nil)
+ (if (null (mark t)) (ding))
+ (setq mark-ring (cdr mark-ring)))
+ (deactivate-mark))
(defalias 'exchange-dot-and-mark 'exchange-point-and-mark)
-(defun exchange-point-and-mark ()
+(defun exchange-point-and-mark (&optional arg)
"Put the mark where point is now, and point where the mark is now.
This command works even when the mark is not active,
-and it reactivates the mark."
- (interactive nil)
- (let ((omark (mark t)))
- (if (null omark)
- (error "No mark set in this buffer"))
- (set-mark (point))
- (goto-char omark)
- nil))
-
-(defun transient-mark-mode (arg)
+and it reactivates the mark.
+With prefix arg, `transient-mark-mode' is enabled temporarily."
+ (interactive "P")
+ (if arg
+ (if mark-active
+ (if (null transient-mark-mode)
+ (setq transient-mark-mode 'lambda))
+ (setq arg nil)))
+ (unless arg
+ (let ((omark (mark t)))
+ (if (null omark)
+ (error "No mark set in this buffer"))
+ (set-mark (point))
+ (goto-char omark)
+ nil)))
+
+(define-minor-mode transient-mark-mode
"Toggle Transient Mark mode.
With arg, turn Transient Mark mode on if arg is positive, off otherwise.
Many commands change their behavior when Transient Mark mode is in effect
and the mark is active, by acting on the region instead of their usual
default part of the buffer's text. Examples of such commands include
-\\[comment-dwim], \\[flush-lines], \\[ispell], \\[keep-lines],
-\\[query-replace], \\[query-replace-regexp], and \\[undo]. Invoke
-\\[apropos-documentation] and type \"transient\" or \"mark.*active\" at
-the prompt, to see the documentation of commands which are sensitive to
-the Transient Mark mode."
- (interactive "P")
- (setq transient-mark-mode
- (if (null arg)
- (not transient-mark-mode)
- (> (prefix-numeric-value arg) 0)))
- (if (interactive-p)
- (if transient-mark-mode
- (message "Transient Mark mode enabled")
- (message "Transient Mark mode disabled"))))
+\\[comment-dwim], \\[flush-lines], \\[keep-lines], \
+\\[query-replace], \\[query-replace-regexp], \\[ispell], and \\[undo].
+Invoke \\[apropos-documentation] and type \"transient\" or
+\"mark.*active\" at the prompt, to see the documentation of
+commands which are sensitive to the Transient Mark mode."
+ :global t :group 'editing-basics :require nil)
+
+(defvar widen-automatically t
+ "Non-nil means it is ok for commands to call `widen' when they want to.
+Some commands will do this in order to go to positions outside
+the current accessible part of the buffer.
+
+If `widen-automatically' is nil, these commands will do something else
+as a fallback, and won't change the buffer bounds.")
(defun pop-global-mark ()
"Pop off global mark ring and jump to the top location."
(set-buffer buffer)
(or (and (>= position (point-min))
(<= position (point-max)))
- (widen))
+ (if widen-automatically
+ (error "Global mark position is outside accessible part of buffer")
+ (widen)))
(goto-char position)
(switch-to-buffer buffer)))
\f
:version "21.1"
:group 'editing-basics)
-(defun next-line (&optional arg)
+(defun next-line (&optional arg try-vscroll)
"Move cursor vertically down ARG lines.
+Interactively, vscroll tall lines if `auto-window-vscroll' is enabled.
If there is no character in the target line exactly under the current column,
the cursor is positioned after the character in that line which spans this
column, or at the end of the line if it is not long enough.
If you are thinking of using this in a Lisp program, consider
using `forward-line' instead. It is usually easier to use
and more reliable (no dependence on goal column, etc.)."
- (interactive "p")
- (unless arg (setq arg 1))
+ (interactive "p\np")
+ (or arg (setq arg 1))
(if (and next-line-add-newlines (= arg 1))
(if (save-excursion (end-of-line) (eobp))
;; When adding a newline, don't expand an abbrev.
(let ((abbrev-mode nil))
(end-of-line)
(insert "\n"))
- (line-move arg))
+ (line-move arg nil nil try-vscroll))
(if (interactive-p)
(condition-case nil
- (line-move arg)
+ (line-move arg nil nil try-vscroll)
((beginning-of-buffer end-of-buffer) (ding)))
- (line-move arg)))
+ (line-move arg nil nil try-vscroll)))
nil)
-(defun previous-line (&optional arg)
+(defun previous-line (&optional arg try-vscroll)
"Move cursor vertically up ARG lines.
+Interactively, vscroll tall lines if `auto-window-vscroll' is enabled.
If there is no character in the target line exactly over the current column,
the cursor is positioned after the character in that line which spans this
column, or at the end of the line if it is not long enough.
If you are thinking of using this in a Lisp program, consider using
`forward-line' with a negative argument instead. It is usually easier
to use and more reliable (no dependence on goal column, etc.)."
- (interactive "p")
- (unless arg (setq arg 1))
+ (interactive "p\np")
+ (or arg (setq arg 1))
(if (interactive-p)
(condition-case nil
- (line-move (- arg))
+ (line-move (- arg) nil nil try-vscroll)
((beginning-of-buffer end-of-buffer) (ding)))
- (line-move (- arg)))
+ (line-move (- arg) nil nil try-vscroll))
nil)
(defcustom track-eol nil
at the start of current run of vertical motion commands.
When the `track-eol' feature is doing its job, the value is 9999.")
-(defcustom line-move-ignore-invisible nil
+(defcustom line-move-ignore-invisible t
"*Non-nil means \\[next-line] and \\[previous-line] ignore invisible lines.
Outline mode sets this."
:type 'boolean
:group 'editing-basics)
-(defun line-move-invisible (pos)
+(defun line-move-invisible-p (pos)
"Return non-nil if the character after POS is currently invisible."
(let ((prop
(get-char-property pos 'invisible)))
(or (memq prop buffer-invisibility-spec)
(assq prop buffer-invisibility-spec)))))
+;; This is like line-move-1 except that it also performs
+;; vertical scrolling of tall images if appropriate.
+;; That is not really a clean thing to do, since it mixes
+;; scrolling with cursor motion. But so far we don't have
+;; a cleaner solution to the problem of making C-n do something
+;; useful given a tall image.
+(defun line-move (arg &optional noerror to-end try-vscroll)
+ (if (and auto-window-vscroll try-vscroll
+ ;; But don't vscroll in a keyboard macro.
+ (not defining-kbd-macro)
+ (not executing-kbd-macro))
+ (let ((forward (> arg 0))
+ (part (nth 2 (pos-visible-in-window-p (point) nil t))))
+ (if (and (consp part)
+ (> (if forward (cdr part) (car part)) 0))
+ (set-window-vscroll nil
+ (if forward
+ (+ (window-vscroll nil t)
+ (min (cdr part)
+ (* (frame-char-height) arg)))
+ (max 0
+ (- (window-vscroll nil t)
+ (min (car part)
+ (* (frame-char-height) (- arg))))))
+ t)
+ (set-window-vscroll nil 0)
+ (when (line-move-1 arg noerror to-end)
+ (when (not forward)
+ ;; Update display before calling pos-visible-in-window-p,
+ ;; because it depends on window-start being up-to-date.
+ (sit-for 0)
+ ;; If the current line is partly hidden at the bottom,
+ ;; scroll it partially up so as to unhide the bottom.
+ (if (and (setq part (nth 2 (pos-visible-in-window-p
+ (line-beginning-position) nil t)))
+ (> (cdr part) 0))
+ (set-window-vscroll nil (cdr part) t)))
+ t)))
+ (line-move-1 arg noerror to-end)))
+
;; This is the guts of next-line and previous-line.
;; Arg says how many lines to move.
-(defun line-move (arg)
+;; The value is t if we can move the specified number of lines.
+(defun line-move-1 (arg &optional noerror to-end)
;; Don't run any point-motion hooks, and disregard intangibility,
;; for intermediate positions.
(let ((inhibit-point-motion-hooks t)
(opoint (point))
- new line-end line-beg)
+ (forward (> arg 0)))
(unwind-protect
(progn
- (if (not (or (eq last-command 'next-line)
- (eq last-command 'previous-line)))
+ (if (not (memq last-command '(next-line previous-line)))
(setq temporary-goal-column
(if (and track-eol (eolp)
;; Don't count beg of empty line as end of line
(or (not (bolp)) (eq last-command 'end-of-line)))
9999
(current-column))))
+
(if (and (not (integerp selective-display))
(not line-move-ignore-invisible))
;; Use just newline characters.
(and (zerop (forward-line arg))
(bolp)
(setq arg 0)))
- (signal (if (< arg 0)
- 'beginning-of-buffer
- 'end-of-buffer)
- nil))
+ (unless noerror
+ (signal (if (< arg 0)
+ 'beginning-of-buffer
+ 'end-of-buffer)
+ nil)))
;; Move by arg lines, but ignore invisible ones.
- (while (> arg 0)
- ;; If the following character is currently invisible,
- ;; skip all characters with that same `invisible' property value.
- (while (and (not (eobp)) (line-move-invisible (point)))
- (goto-char (next-char-property-change (point))))
- ;; Now move a line.
- (end-of-line)
- (and (zerop (vertical-motion 1))
- (signal 'end-of-buffer nil))
- (setq arg (1- arg)))
- (while (< arg 0)
- (beginning-of-line)
- (and (zerop (vertical-motion -1))
- (signal 'beginning-of-buffer nil))
- (setq arg (1+ arg))
- (while (and (not (bobp)) (line-move-invisible (1- (point))))
- (goto-char (previous-char-property-change (point)))))))
+ (let (done)
+ (while (and (> arg 0) (not done))
+ ;; If the following character is currently invisible,
+ ;; skip all characters with that same `invisible' property value.
+ (while (and (not (eobp)) (line-move-invisible-p (point)))
+ (goto-char (next-char-property-change (point))))
+ ;; Now move a line.
+ (end-of-line)
+ ;; If there's no invisibility here, move over the newline.
+ (if (and (not (integerp selective-display))
+ (not (line-move-invisible-p (point))))
+ ;; We avoid vertical-motion when possible
+ ;; because that has to fontify.
+ (if (eobp)
+ (if (not noerror)
+ (signal 'end-of-buffer nil)
+ (setq done t))
+ (forward-line 1))
+ ;; Otherwise move a more sophisticated way.
+ ;; (What's the logic behind this code?)
+ (and (zerop (vertical-motion 1))
+ (if (not noerror)
+ (signal 'end-of-buffer nil)
+ (setq done t))))
+ (unless done
+ (setq arg (1- arg))))
+ ;; The logic of this is the same as the loop above,
+ ;; it just goes in the other direction.
+ (while (and (< arg 0) (not done))
+ (beginning-of-line)
+ (if (or (bobp)
+ (and (not (integerp selective-display))
+ (not (line-move-invisible-p (1- (point))))))
+ (if (bobp)
+ (if (not noerror)
+ (signal 'beginning-of-buffer nil)
+ (setq done t))
+ (forward-line -1))
+ (if (zerop (vertical-motion -1))
+ (if (not noerror)
+ (signal 'beginning-of-buffer nil)
+ (setq done t))))
+ (unless done
+ (setq arg (1+ arg))
+ (while (and ;; Don't move over previous invis lines
+ ;; if our target is the middle of this line.
+ (or (zerop (or goal-column temporary-goal-column))
+ (< arg 0))
+ (not (bobp)) (line-move-invisible-p (1- (point))))
+ (goto-char (previous-char-property-change (point))))))))
+ ;; This is the value the function returns.
+ (= arg 0))
(cond ((> arg 0)
;; If we did not move down as far as desired,
;; at least go to end of line.
(beginning-of-line))
(t
- (line-move-finish (or goal-column temporary-goal-column) opoint)))))
- nil)
+ (line-move-finish (or goal-column temporary-goal-column)
+ opoint forward))))))
-(defun line-move-finish (column opoint)
+(defun line-move-finish (column opoint forward)
(let ((repeat t))
(while repeat
;; Set REPEAT to t to repeat the whole thing.
(setq repeat nil)
- ;; Move to the desired column.
- (line-move-to-column column)
-
- (let ((new (point))
+ (let (new
(line-beg (save-excursion (beginning-of-line) (point)))
- (line-end (save-excursion (end-of-line) (point))))
+ (line-end
+ ;; Compute the end of the line
+ ;; ignoring effectively invisible newlines.
+ (save-excursion
+ (end-of-line)
+ (while (and (not (eobp)) (line-move-invisible-p (point)))
+ (goto-char (next-char-property-change (point)))
+ (end-of-line))
+ (point))))
+
+ ;; Move to the desired column.
+ (line-move-to-column column)
+ (setq new (point))
;; Process intangibility within a line.
;; Move to the chosen destination position from above,
;; If intangibility moves us to a different (later) place
;; in the same line, use that as the destination.
(if (<= (point) line-end)
- (setq new (point))))
+ (setq new (point))
+ ;; If that position is "too late",
+ ;; try the previous allowable position.
+ ;; See if it is ok.
+ (backward-char)
+ (if (if forward
+ ;; If going forward, don't accept the previous
+ ;; allowable position if it is before the target line.
+ (< line-beg (point))
+ ;; If going backward, don't accept the previous
+ ;; allowable position if it is still after the target line.
+ (<= (point) line-end))
+ (setq new (point))
+ ;; As a last resort, use the end of the line.
+ (setq new line-end))))
;; Now move to the updated destination, processing fields
;; as well as intangibility.
(constrain-to-field new opoint nil t
'inhibit-line-move-field-capture)))
- ;; If intangibility processing moved us to a different line,
+ ;; If all this moved us to a different line,
;; retry everything within that new line.
(when (or (< (point) line-beg) (> (point) line-end))
;; Repeat the intangibility and field processing.
(move-to-column col))
(when (and line-move-ignore-invisible
- (not (bolp)) (line-move-invisible (1- (point))))
+ (not (bolp)) (line-move-invisible-p (1- (point))))
(let ((normal-location (point))
(normal-column (current-column)))
;; If the following character is currently invisible,
;; skip all characters with that same `invisible' property value.
(while (and (not (eobp))
- (line-move-invisible (point)))
+ (line-move-invisible-p (point)))
(goto-char (next-char-property-change (point))))
;; Have we advanced to a larger column position?
(if (> (current-column) normal-column)
;; but with a more reasonable buffer position.
(goto-char normal-location)
(let ((line-beg (save-excursion (beginning-of-line) (point))))
- (while (and (not (bolp)) (line-move-invisible (1- (point))))
+ (while (and (not (bolp)) (line-move-invisible-p (1- (point))))
(goto-char (previous-char-property-change (point) line-beg))))))))
+(defun move-end-of-line (arg)
+ "Move point to end of current line.
+With argument ARG not nil or 1, move forward ARG - 1 lines first.
+If point reaches the beginning or end of buffer, it stops there.
+To ignore intangibility, bind `inhibit-point-motion-hooks' to t.
+
+This command does not move point across a field boundary unless doing so
+would move beyond there to a different line; if ARG is nil or 1, and
+point starts at a field boundary, point does not move. To ignore field
+boundaries bind `inhibit-field-text-motion' to t."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (let (done)
+ (while (not done)
+ (let ((newpos
+ (save-excursion
+ (let ((goal-column 0))
+ (and (line-move arg t)
+ (not (bobp))
+ (progn
+ (while (and (not (bobp)) (line-move-invisible-p (1- (point))))
+ (goto-char (previous-char-property-change (point))))
+ (backward-char 1)))
+ (point)))))
+ (goto-char newpos)
+ (if (and (> (point) newpos)
+ (eq (preceding-char) ?\n))
+ (backward-char 1)
+ (if (and (> (point) newpos) (not (eobp))
+ (not (eq (following-char) ?\n)))
+ ;; If we skipped something intangible
+ ;; and now we're not really at eol,
+ ;; keep going.
+ (setq arg 1)
+ (setq done t)))))))
+
+(defun move-beginning-of-line (arg)
+ "Move point to beginning of current display line.
+With argument ARG not nil or 1, move forward ARG - 1 lines first.
+If point reaches the beginning or end of buffer, it stops there.
+To ignore intangibility, bind `inhibit-point-motion-hooks' to t.
+
+This command does not move point across a field boundary unless doing so
+would move beyond there to a different line; if ARG is nil or 1, and
+point starts at a field boundary, point does not move. To ignore field
+boundaries bind `inhibit-field-text-motion' to t."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (if (/= arg 1)
+ (line-move (1- arg) t))
+ (beginning-of-line 1)
+ (let ((orig (point)))
+ (vertical-motion 0)
+ (if (/= orig (point))
+ (goto-char (constrain-to-field (point) orig (/= arg 1) t nil)))))
+
+
;;; Many people have said they rarely use this feature, and often type
;;; it by accident. Maybe it shouldn't even be on a key.
(put 'set-goal-column 'disabled t)
(if (eq lines '-) nil
(if (null lines) '-
(- (prefix-numeric-value lines))))))
-(define-key esc-map [?\C-\S-v] 'scroll-other-window-down)
(defun beginning-of-buffer-other-window (arg)
"Move point to the beginning of the buffer in the other window.
(progn
(select-window window)
;; Set point and mark in that window's buffer.
- (beginning-of-buffer arg)
+ (with-no-warnings
+ (beginning-of-buffer arg))
;; Set point accordingly.
(recenter '(t)))
(select-window orig-window))))
(unwind-protect
(progn
(select-window window)
- (end-of-buffer arg)
+ (with-no-warnings
+ (end-of-buffer arg))
(recenter '(t)))
(select-window orig-window))))
\f
and drag it forward past ARG other words (backward if ARG negative).
If ARG is zero, the words around or after point and around or after mark
are interchanged."
+ ;; FIXME: `foo a!nd bar' should transpose into `bar and foo'.
(interactive "*p")
(transpose-subr 'forward-word arg))
Does not work on a sexp that point is in the middle of
if it is a list or string."
(interactive "*p")
- (transpose-subr 'forward-sexp arg))
+ (transpose-subr
+ (lambda (arg)
+ ;; Here we should try to simulate the behavior of
+ ;; (cons (progn (forward-sexp x) (point))
+ ;; (progn (forward-sexp (- x)) (point)))
+ ;; Except that we don't want to rely on the second forward-sexp
+ ;; putting us back to where we want to be, since forward-sexp-function
+ ;; might do funny things like infix-precedence.
+ (if (if (> arg 0)
+ (looking-at "\\sw\\|\\s_")
+ (and (not (bobp))
+ (save-excursion (forward-char -1) (looking-at "\\sw\\|\\s_"))))
+ ;; Jumping over a symbol. We might be inside it, mind you.
+ (progn (funcall (if (> arg 0)
+ 'skip-syntax-backward 'skip-syntax-forward)
+ "w_")
+ (cons (save-excursion (forward-sexp arg) (point)) (point)))
+ ;; Otherwise, we're between sexps. Take a step back before jumping
+ ;; to make sure we'll obey the same precedence no matter which direction
+ ;; we're going.
+ (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) " .")
+ (cons (save-excursion (forward-sexp arg) (point))
+ (progn (while (or (forward-comment (if (> arg 0) 1 -1))
+ (not (zerop (funcall (if (> arg 0)
+ 'skip-syntax-forward
+ 'skip-syntax-backward)
+ ".")))))
+ (point)))))
+ arg 'special))
(defun transpose-lines (arg)
"Exchange current line and previous line, leaving point after both.
(if (> (cdr pos1) (car pos2)) (error "Don't have two things to transpose"))
(atomic-change-group
(let (word2)
+ ;; FIXME: We first delete the two pieces of text, so markers that
+ ;; used to point to after the text end up pointing to before it :-(
(setq word2 (delete-and-extract-region (car pos2) (cdr pos2)))
(goto-char (car pos2))
(insert (delete-and-extract-region (car pos1) (cdr pos1)))
(goto-char (car pos1))
(insert word2))))
\f
-(defun backward-word (arg)
+(defun backward-word (&optional arg)
"Move backward until encountering the beginning of a word.
With argument, do this that many times."
(interactive "p")
- (forward-word (- arg)))
-
-(defun mark-word (arg)
- "Set mark arg words away from point.
-If this command is repeated, it marks the next ARG words after the ones
-already marked."
- (interactive "p")
- (cond ((and (eq last-command this-command) (mark t))
+ (forward-word (- (or arg 1))))
+
+(defun mark-word (&optional arg allow-extend)
+ "Set mark ARG words away from point.
+The place mark goes is the same place \\[forward-word] would
+move to with the same argument.
+Interactively, if this command is repeated
+or (in Transient Mark mode) if the mark is active,
+it marks the next ARG words after the ones already marked."
+ (interactive "P\np")
+ (cond ((and allow-extend
+ (or (and (eq last-command this-command) (mark t))
+ (and transient-mark-mode mark-active)))
+ (setq arg (if arg (prefix-numeric-value arg)
+ (if (< (mark) (point)) -1 1)))
(set-mark
(save-excursion
(goto-char (mark))
(t
(push-mark
(save-excursion
- (forward-word arg)
+ (forward-word (prefix-numeric-value arg))
(point))
nil t))))
(interactive "p")
(kill-word (- arg)))
-(defun current-word (&optional strict)
- "Return the word point is on (or a nearby word) as a string.
+(defun current-word (&optional strict really-word)
+ "Return the symbol or word that point is on (or a nearby one) as a string.
+The return value includes no text properties.
If optional arg STRICT is non-nil, return nil unless point is within
-or adjacent to a word."
+or adjacent to a symbol or word. In all cases the value can be nil
+if there is no word nearby.
+The function, belying its name, normally finds a symbol.
+If optional arg REALLY-WORD is non-nil, it finds just a word."
(save-excursion
- (let ((oldpoint (point)) (start (point)) (end (point)))
- (skip-syntax-backward "w_") (setq start (point))
+ (let* ((oldpoint (point)) (start (point)) (end (point))
+ (syntaxes (if really-word "w" "w_"))
+ (not-syntaxes (concat "^" syntaxes)))
+ (skip-syntax-backward syntaxes) (setq start (point))
(goto-char oldpoint)
- (skip-syntax-forward "w_") (setq end (point))
- (if (and (eq start oldpoint) (eq end oldpoint))
- ;; Point is neither within nor adjacent to a word.
- (and (not strict)
- (progn
- ;; Look for preceding word in same line.
- (skip-syntax-backward "^w_"
- (save-excursion (beginning-of-line)
- (point)))
- (if (bolp)
- ;; No preceding word in same line.
- ;; Look for following word in same line.
- (progn
- (skip-syntax-forward "^w_"
- (save-excursion (end-of-line)
- (point)))
- (setq start (point))
- (skip-syntax-forward "w_")
- (setq end (point)))
- (setq end (point))
- (skip-syntax-backward "w_")
- (setq start (point)))
- (buffer-substring-no-properties start end)))
+ (skip-syntax-forward syntaxes) (setq end (point))
+ (when (and (eq start oldpoint) (eq end oldpoint)
+ ;; Point is neither within nor adjacent to a word.
+ (not strict))
+ ;; Look for preceding word in same line.
+ (skip-syntax-backward not-syntaxes
+ (save-excursion (beginning-of-line)
+ (point)))
+ (if (bolp)
+ ;; No preceding word in same line.
+ ;; Look for following word in same line.
+ (progn
+ (skip-syntax-forward not-syntaxes
+ (save-excursion (end-of-line)
+ (point)))
+ (setq start (point))
+ (skip-syntax-forward syntaxes)
+ (setq end (point)))
+ (setq end (point))
+ (skip-syntax-backward syntaxes)
+ (setq start (point))))
+ ;; If we found something nonempty, return it as a string.
+ (unless (= start end)
(buffer-substring-no-properties start end)))))
\f
(defcustom fill-prefix nil
;; (Actually some major modes use a different auto-fill function,
;; but this one is the default one.)
(defun do-auto-fill ()
- (let (fc justify bol give-up
+ (let (fc justify give-up
(fill-prefix fill-prefix))
(if (or (not (setq justify (current-justification)))
(null (setq fc (current-fill-column)))
(and (eq justify 'left)
(<= (current-column) fc))
- (save-excursion (beginning-of-line)
- (setq bol (point))
- (and auto-fill-inhibit-regexp
+ (and auto-fill-inhibit-regexp
+ (save-excursion (beginning-of-line)
(looking-at auto-fill-inhibit-regexp))))
nil ;; Auto-filling not required
(if (memq justify '(full center right))
(and prefix (not (equal prefix ""))
;; Use auto-indentation rather than a guessed empty prefix.
(not (and fill-indent-according-to-mode
- (string-match "[ \t]*" prefix)))
+ (string-match "\\`[ \t]*\\'" prefix)))
(setq fill-prefix prefix))))
-
+
(while (and (not give-up) (> (current-column) fc))
;; Determine where to split the line.
(let* (after-prefix
(fill-point
- (let ((opoint (point))
- bounce
- (first t))
- (save-excursion
- (beginning-of-line)
- (setq after-prefix (point))
- (and fill-prefix
- (looking-at (regexp-quote fill-prefix))
- (setq after-prefix (match-end 0)))
- (move-to-column (1+ fc))
- ;; Move back to the point where we can break the line.
- ;; We break the line between word or
- ;; after/before the character which has character
- ;; category `|'. We search space, \c| followed by
- ;; a character, or \c| following a character. If
- ;; not found, place the point at beginning of line.
- (while (or first
- (and (not (bobp))
- (not bounce)
- (fill-nobreak-p)))
- (setq first nil)
- (re-search-backward "[ \t]\\|\\c|.\\|.\\c|\\|^")
- ;; If we find nowhere on the line to break it,
- ;; break after one word. Set bounce to t
- ;; so we will not keep going in this while loop.
- (if (<= (point) after-prefix)
- (progn
- (goto-char after-prefix)
- (re-search-forward "[ \t]" opoint t)
- (setq bounce t))
- (if (looking-at "[ \t]")
- ;; Break the line at word boundary.
- (skip-chars-backward " \t")
- ;; Break the line after/before \c|.
- (forward-char 1))))
- (if enable-multibyte-characters
- ;; If we are going to break the line after or
- ;; before a non-ascii character, we may have
- ;; to run a special function for the charset
- ;; of the character to find the correct break
- ;; point.
- (if (not (and (eq (charset-after (1- (point))) 'ascii)
- (eq (charset-after (point)) 'ascii)))
- (fill-find-break-point after-prefix)))
-
- ;; Let fill-point be set to the place where we end up.
- ;; But move back before any whitespace here.
- (skip-chars-backward " \t")
- (point)))))
+ (save-excursion
+ (beginning-of-line)
+ (setq after-prefix (point))
+ (and fill-prefix
+ (looking-at (regexp-quote fill-prefix))
+ (setq after-prefix (match-end 0)))
+ (move-to-column (1+ fc))
+ (fill-move-to-break-point after-prefix)
+ (point))))
;; See whether the place we found is any good.
(if (save-excursion
(goto-char fill-point)
- (and (not (bolp))
- ;; There is no use breaking at end of line.
- (not (save-excursion (skip-chars-forward " ") (eolp)))
- ;; It is futile to split at the end of the prefix
- ;; since we would just insert the prefix again.
- (not (and after-prefix (<= (point) after-prefix)))
- ;; Don't split right after a comment starter
- ;; since we would just make another comment starter.
- (not (and comment-start-skip
- (let ((limit (point)))
- (beginning-of-line)
- (and (re-search-forward comment-start-skip
- limit t)
- (eq (point) limit)))))))
- ;; Ok, we have a useful place to break the line. Do it.
- (let ((prev-column (current-column)))
- ;; If point is at the fill-point, do not `save-excursion'.
- ;; Otherwise, if a comment prefix or fill-prefix is inserted,
- ;; point will end up before it rather than after it.
- (if (save-excursion
- (skip-chars-backward " \t")
- (= (point) fill-point))
- (funcall comment-line-break-function t)
+ (or (bolp)
+ ;; There is no use breaking at end of line.
+ (save-excursion (skip-chars-forward " ") (eolp))
+ ;; It is futile to split at the end of the prefix
+ ;; since we would just insert the prefix again.
+ (and after-prefix (<= (point) after-prefix))
+ ;; Don't split right after a comment starter
+ ;; since we would just make another comment starter.
+ (and comment-start-skip
+ (let ((limit (point)))
+ (beginning-of-line)
+ (and (re-search-forward comment-start-skip
+ limit t)
+ (eq (point) limit))))))
+ ;; No good place to break => stop trying.
+ (setq give-up t)
+ ;; Ok, we have a useful place to break the line. Do it.
+ (let ((prev-column (current-column)))
+ ;; If point is at the fill-point, do not `save-excursion'.
+ ;; Otherwise, if a comment prefix or fill-prefix is inserted,
+ ;; point will end up before it rather than after it.
+ (if (save-excursion
+ (skip-chars-backward " \t")
+ (= (point) fill-point))
+ (funcall comment-line-break-function t)
+ (save-excursion
+ (goto-char fill-point)
+ (funcall comment-line-break-function t)))
+ ;; Now do justification, if required
+ (if (not (eq justify 'left))
(save-excursion
- (goto-char fill-point)
- (funcall comment-line-break-function t)))
- ;; Now do justification, if required
- (if (not (eq justify 'left))
- (save-excursion
(end-of-line 0)
(justify-current-line justify nil t)))
- ;; If making the new line didn't reduce the hpos of
- ;; the end of the line, then give up now;
- ;; trying again will not help.
- (if (>= (current-column) prev-column)
- (setq give-up t)))
- ;; No good place to break => stop trying.
- (setq give-up t))))
+ ;; If making the new line didn't reduce the hpos of
+ ;; the end of the line, then give up now;
+ ;; trying again will not help.
+ (if (>= (current-column) prev-column)
+ (setq give-up t))))))
;; Justify last line.
(justify-current-line justify t t)
t)))
"The function to use for `auto-fill-function' if Auto Fill mode is turned on.
Some major modes set this.")
+(put 'auto-fill-function :minor-mode-function 'auto-fill-mode)
+;; FIXME: turn into a proper minor mode.
+;; Add a global minor mode version of it.
(defun auto-fill-mode (&optional arg)
"Toggle Auto Fill mode.
With arg, turn Auto Fill mode on if and only if arg is positive.
(setq arg (current-column)))
(if (not (integerp arg))
;; Disallow missing argument; it's probably a typo for C-x C-f.
- (error "set-fill-column requires an explicit argument")
+ (error "Set-fill-column requires an explicit argument")
(message "Fill column set to %d (was %d)" arg fill-column)
(setq fill-column arg)))
\f
(prin1 selective-display t)
(princ "." t))
+(defvaralias 'indicate-unused-lines 'indicate-empty-lines)
+(defvaralias 'default-indicate-unused-lines 'default-indicate-empty-lines)
+
+(defun toggle-truncate-lines (arg)
+ "Toggle whether to fold or truncate long lines on the screen.
+With arg, truncate long lines iff arg is positive.
+Note that in side-by-side windows, truncation is always enabled."
+ (interactive "P")
+ (setq truncate-lines
+ (if (null arg)
+ (not truncate-lines)
+ (> (prefix-numeric-value arg) 0)))
+ (force-mode-line-update)
+ (unless truncate-lines
+ (let ((buffer (current-buffer)))
+ (walk-windows (lambda (window)
+ (if (eq buffer (window-buffer window))
+ (set-window-hscroll window 0)))
+ nil t)))
+ (message "Truncate long lines %s"
+ (if truncate-lines "enabled" "disabled")))
+
(defvar overwrite-mode-textual " Ovwrt"
"The string displayed in the mode line when in overwrite mode.")
(defvar overwrite-mode-binary " Bin Ovwrt"
'overwrite-mode-binary))
(force-mode-line-update))
-(defcustom line-number-mode t
- "*Non-nil means display line number in mode line."
- :type 'boolean
- :group 'editing-basics)
-
-(defun line-number-mode (arg)
+(define-minor-mode line-number-mode
"Toggle Line Number mode.
With arg, turn Line Number mode on iff arg is positive.
When Line Number mode is enabled, the line number appears
Line numbers do not appear for very large buffers and buffers
with very long lines; see variables `line-number-display-limit'
and `line-number-display-limit-width'."
- (interactive "P")
- (setq line-number-mode
- (if (null arg) (not line-number-mode)
- (> (prefix-numeric-value arg) 0)))
- (force-mode-line-update))
-
-(defcustom column-number-mode nil
- "*Non-nil means display column number in mode line."
- :type 'boolean
- :group 'editing-basics)
+ :init-value t :global t :group 'editing-basics :require nil)
-(defun column-number-mode (arg)
+(define-minor-mode column-number-mode
"Toggle Column Number mode.
With arg, turn Column Number mode on iff arg is positive.
When Column Number mode is enabled, the column number appears
in the mode line."
- (interactive "P")
- (setq column-number-mode
- (if (null arg) (not column-number-mode)
- (> (prefix-numeric-value arg) 0)))
- (force-mode-line-update))
+ :global t :group 'editing-basics :require nil)
+
+(define-minor-mode size-indication-mode
+ "Toggle Size Indication mode.
+With arg, turn Size Indication mode on iff arg is positive. When
+Size Indication mode is enabled, the size of the accessible part
+of the buffer appears in the mode line."
+ :global t :group 'editing-basics :require nil)
\f
(defgroup paren-blinking nil
"Blinking matching of parens and expressions."
(point)))))
(let* ((oldpos (point))
(blinkpos)
- (mismatch))
+ (mismatch)
+ matching-paren)
(save-excursion
(save-restriction
(if blink-matching-paren-distance
(setq blinkpos (scan-sexps oldpos -1)))
(error nil)))
(and blinkpos
- (/= (char-syntax (char-after blinkpos))
- ?\$)
- (setq mismatch
- (or (null (matching-paren (char-after blinkpos)))
+ ;; Not syntax '$'.
+ (not (eq (syntax-class (syntax-after blinkpos)) 8))
+ (setq matching-paren
+ (let ((syntax (syntax-after blinkpos)))
+ (and (consp syntax)
+ (eq (syntax-class syntax) 4)
+ (cdr syntax)))
+ mismatch
+ (or (null matching-paren)
(/= (char-after (1- oldpos))
- (matching-paren (char-after blinkpos))))))
+ matching-paren))))
(if mismatch (setq blinkpos nil))
(if blinkpos
;; Don't log messages about paren matching.
At top-level, as an editor command, this simply beeps."
(interactive)
(deactivate-mark)
+ (if (fboundp 'kmacro-keyboard-quit)
+ (kmacro-keyboard-quit))
+ (setq defining-kbd-macro nil)
(signal 'quit nil))
-(define-key global-map "\C-g" 'keyboard-quit)
-
(defvar buffer-quit-function nil
"Function to call to \"quit\" the current buffer, or nil if none.
\\[keyboard-escape-quit] calls this function when its more local actions
(abort-recursive-edit))
(current-prefix-arg
nil)
- ((and transient-mark-mode
- mark-active)
+ ((and transient-mark-mode mark-active)
(deactivate-mark))
((> (recursion-depth) 0)
(exit-recursive-edit))
(push 'sound sound)
(play-sound sound)))
-(define-key global-map "\e\e\e" 'keyboard-escape-quit)
-
+\f
(defcustom read-mail-command 'rmail
"*Your preference for a mail reading package.
This is used by some keybindings which support reading mail.
(function :tag "Other"))
:group 'mail)
-(defun define-mail-user-agent (symbol composefunc sendfunc
- &optional abortfunc hookvar)
- "Define a symbol to identify a mail-sending package for `mail-user-agent'.
-
-SYMBOL can be any Lisp symbol. Its function definition and/or
-value as a variable do not matter for this usage; we use only certain
-properties on its property list, to encode the rest of the arguments.
-
-COMPOSEFUNC is program callable function that composes an outgoing
-mail message buffer. This function should set up the basics of the
-buffer without requiring user interaction. It should populate the
-standard mail headers, leaving the `to:' and `subject:' headers blank
-by default.
-
-COMPOSEFUNC should accept several optional arguments--the same
-arguments that `compose-mail' takes. See that function's documentation.
-
-SENDFUNC is the command a user would run to send the message.
-
-Optional ABORTFUNC is the command a user would run to abort the
-message. For mail packages that don't have a separate abort function,
-this can be `kill-buffer' (the equivalent of omitting this argument).
-
-Optional HOOKVAR is a hook variable that gets run before the message
-is actually sent. Callers that use the `mail-user-agent' may
-install a hook function temporarily on this hook variable.
-If HOOKVAR is nil, `mail-send-hook' is used.
-
-The properties used on SYMBOL are `composefunc', `sendfunc',
-`abortfunc', and `hookvar'."
- (put symbol 'composefunc composefunc)
- (put symbol 'sendfunc sendfunc)
- (put symbol 'abortfunc (or abortfunc 'kill-buffer))
- (put symbol 'hookvar (or hookvar 'mail-send-hook)))
-
(define-mail-user-agent 'sendmail-user-agent
'sendmail-user-agent-compose
'mail-send-and-exit)
(same-window-buffer-names nil)
(same-window-regexps nil))
(funcall switch-function "*mail*")))
- (let ((cc (cdr (assoc-ignore-case "cc" other-headers)))
- (in-reply-to (cdr (assoc-ignore-case "in-reply-to" other-headers)))
- (body (cdr (assoc-ignore-case "body" other-headers))))
+ (let ((cc (cdr (assoc-string "cc" other-headers t)))
+ (in-reply-to (cdr (assoc-string "in-reply-to" other-headers t)))
+ (body (cdr (assoc-string "body" other-headers t))))
(or (mail continue to subject in-reply-to cc yank-action send-actions)
continue
(error "Message aborted"))
(list nil nil nil current-prefix-arg))
(compose-mail to subject other-headers continue
'switch-to-buffer-other-frame yank-action send-actions))
-
+\f
(defvar set-variable-value-history nil
"History of values entered with `set-variable'.")
-(defun set-variable (var val)
+(defun set-variable (var val &optional make-local)
"Set VARIABLE to VALUE. VALUE is a Lisp object.
When using this interactively, enter a Lisp object for VALUE.
If you want VALUE to be a string, you must surround it with doublequotes.
it were the arg to `interactive' (which see) to interactively read VALUE.
If VARIABLE has been defined with `defcustom', then the type information
-in the definition is used to check that VALUE is valid."
+in the definition is used to check that VALUE is valid.
+
+With a prefix argument, set VARIABLE to VALUE buffer-locally."
(interactive
(let* ((default-var (variable-at-point))
(var (if (symbolp default-var)
(read-variable (format "Set variable (default %s): " default-var)
default-var)
(read-variable "Set variable: ")))
- (minibuffer-help-form '(describe-variable var))
- (prop (get var 'variable-interactive))
- (prompt (format "Set %s to value: " var))
- (val (if prop
- ;; Use VAR's `variable-interactive' property
- ;; as an interactive spec for prompting.
- (call-interactively `(lambda (arg)
- (interactive ,prop)
- arg))
- (read
- (read-string prompt nil
- 'set-variable-value-history)))))
- (list var val)))
-
+ (minibuffer-help-form '(describe-variable var))
+ (prop (get var 'variable-interactive))
+ (prompt (format "Set %s%s to value: " var
+ (cond ((local-variable-p var)
+ " (buffer-local)")
+ ((or current-prefix-arg
+ (local-variable-if-set-p var))
+ " buffer-locally")
+ (t " globally"))))
+ (val (if prop
+ ;; Use VAR's `variable-interactive' property
+ ;; as an interactive spec for prompting.
+ (call-interactively `(lambda (arg)
+ (interactive ,prop)
+ arg))
+ (read
+ (read-string prompt nil
+ 'set-variable-value-history)))))
+ (list var val current-prefix-arg)))
+
+ (and (custom-variable-p var)
+ (not (get var 'custom-type))
+ (custom-load-symbol var))
(let ((type (get var 'custom-type)))
(when type
;; Match with custom type.
(unless (widget-apply type :match val)
(error "Value `%S' does not match type %S of %S"
val (car type) var))))
+
+ (if make-local
+ (make-local-variable var))
+
(set var val)
;; Force a thorough redisplay for the case that the variable
;; has an effect on the display, like `tab-width' has.
(force-mode-line-update))
-
+\f
;; Define the major mode for lists of completions.
(defvar completion-list-mode-map nil
(or completion-list-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [mouse-2] 'mouse-choose-completion)
+ (define-key map [follow-link] 'mouse-face)
(define-key map [down-mouse-2] nil)
(define-key map "\C-m" 'choose-completion)
(define-key map "\e\e\e" 'delete-completion-window)
;; that can be found before POINT.
(defun choose-completion-delete-max-match (string)
(let ((opoint (point))
- (len (min (length string)
- (- (point) (point-min)))))
- (goto-char (- (point) (length string)))
+ len)
+ ;; Try moving back by the length of the string.
+ (goto-char (max (- (point) (length string))
+ (minibuffer-prompt-end)))
+ ;; See how far back we were actually able to move. That is the
+ ;; upper bound on how much we can match and delete.
+ (setq len (- opoint (point)))
(if completion-ignore-case
(setq string (downcase string)))
(while (and (> len 0)
- (let ((tail (buffer-substring (point)
- (+ (point) len))))
+ (let ((tail (buffer-substring (point) opoint)))
(if completion-ignore-case
(setq tail (downcase tail)))
(not (string= tail (substring string 0 len)))))
(forward-char 1))
(delete-char len)))
-;; Switch to BUFFER and insert the completion choice CHOICE.
-;; BASE-SIZE, if non-nil, says how many characters of BUFFER's text
-;; to keep. If it is nil, use choose-completion-delete-max-match instead.
+(defvar choose-completion-string-functions nil
+ "Functions that may override the normal insertion of a completion choice.
+These functions are called in order with four arguments:
+CHOICE - the string to insert in the buffer,
+BUFFER - the buffer in which the choice should be inserted,
+MINI-P - non-nil iff BUFFER is a minibuffer, and
+BASE-SIZE - the number of characters in BUFFER before
+the string being completed.
+
+If a function in the list returns non-nil, that function is supposed
+to have inserted the CHOICE in the BUFFER, and possibly exited
+the minibuffer; no further functions will be called.
+
+If all functions in the list return nil, that means to use
+the default method of inserting the completion in BUFFER.")
-;; If BUFFER is the minibuffer, exit the minibuffer
-;; unless it is reading a file name and CHOICE is a directory,
-;; or completion-no-auto-exit is non-nil.
(defun choose-completion-string (choice &optional buffer base-size)
- (let ((buffer (or buffer completion-reference-buffer))
- (mini-p (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer))))
+ "Switch to BUFFER and insert the completion choice CHOICE.
+BASE-SIZE, if non-nil, says how many characters of BUFFER's text
+to keep. If it is nil, we call `choose-completion-delete-max-match'
+to decide what to delete."
+
+ ;; If BUFFER is the minibuffer, exit the minibuffer
+ ;; unless it is reading a file name and CHOICE is a directory,
+ ;; or completion-no-auto-exit is non-nil.
+
+ (let* ((buffer (or buffer completion-reference-buffer))
+ (mini-p (minibufferp buffer)))
;; If BUFFER is a minibuffer, barf unless it's the currently
;; active minibuffer.
(if (and mini-p
(not (equal buffer
(window-buffer (active-minibuffer-window))))))
(error "Minibuffer is not active for completion")
- ;; Insert the completion into the buffer where completion was requested.
+ ;; Set buffer so buffer-local choose-completion-string-functions works.
(set-buffer buffer)
- (if base-size
- (delete-region (+ base-size (if mini-p
- (minibuffer-prompt-end)
- (point-min)))
- (point))
- (choose-completion-delete-max-match choice))
- (insert choice)
- (remove-text-properties (- (point) (length choice)) (point)
- '(mouse-face nil))
- ;; Update point in the window that BUFFER is showing in.
- (let ((window (get-buffer-window buffer t)))
- (set-window-point window (point)))
- ;; If completing for the minibuffer, exit it with this choice.
- (and (not completion-no-auto-exit)
- (equal buffer (window-buffer (minibuffer-window)))
- minibuffer-completion-table
- ;; If this is reading a file name, and the file name chosen
- ;; is a directory, don't exit the minibuffer.
- (if (and (eq minibuffer-completion-table 'read-file-name-internal)
- (file-directory-p (field-string (point-max))))
- (let ((mini (active-minibuffer-window)))
- (select-window mini)
- (when minibuffer-auto-raise
- (raise-frame (window-frame mini))))
- (exit-minibuffer))))))
+ (unless (run-hook-with-args-until-success
+ 'choose-completion-string-functions
+ choice buffer mini-p base-size)
+ ;; Insert the completion into the buffer where it was requested.
+ (if base-size
+ (delete-region (+ base-size (if mini-p
+ (minibuffer-prompt-end)
+ (point-min)))
+ (point))
+ (choose-completion-delete-max-match choice))
+ (insert choice)
+ (remove-text-properties (- (point) (length choice)) (point)
+ '(mouse-face nil))
+ ;; Update point in the window that BUFFER is showing in.
+ (let ((window (get-buffer-window buffer t)))
+ (set-window-point window (point)))
+ ;; If completing for the minibuffer, exit it with this choice.
+ (and (not completion-no-auto-exit)
+ (equal buffer (window-buffer (minibuffer-window)))
+ minibuffer-completion-table
+ ;; If this is reading a file name, and the file name chosen
+ ;; is a directory, don't exit the minibuffer.
+ (if (and (eq minibuffer-completion-table 'read-file-name-internal)
+ (file-directory-p (field-string (point-max))))
+ (let ((mini (active-minibuffer-window)))
+ (select-window mini)
+ (when minibuffer-auto-raise
+ (raise-frame (window-frame mini))))
+ (exit-minibuffer)))))))
(defun completion-list-mode ()
"Major mode for buffers showing lists of possible completions.
(setq major-mode 'completion-list-mode)
(make-local-variable 'completion-base-size)
(setq completion-base-size nil)
- (run-hooks 'completion-list-mode-hook))
+ (run-mode-hooks 'completion-list-mode-hook))
(defun completion-list-mode-finish ()
"Finish setup of the completions buffer.
;; This function goes in completion-setup-hook, so that it is called
;; after the text of the completion list buffer is written.
+(defface completions-first-difference
+ '((t (:inherit bold)))
+ "Face put on the first uncommon character in completions in *Completions* buffer."
+ :group 'completion)
+
+(defface completions-common-part
+ '((t (:inherit default)))
+ "Face put on the common prefix substring in completions in *Completions* buffer.
+The idea of `completions-common-part' is that you can use it to
+make the common parts less visible than normal, so that the rest
+of the differing parts is, by contrast, slightly highlighted."
+ :group 'completion)
+
+;; This is for packages that need to bind it to a non-default regexp
+;; in order to make the first-differing character highlight work
+;; to their liking
+(defvar completion-root-regexp "^/"
+ "Regexp to use in `completion-setup-function' to find the root directory.")
(defun completion-setup-function ()
- (save-excursion
- (let ((mainbuf (current-buffer)))
- (set-buffer standard-output)
+ (let ((mainbuf (current-buffer))
+ (mbuf-contents (minibuffer-contents)))
+ ;; When reading a file name in the minibuffer,
+ ;; set default-directory in the minibuffer
+ ;; so it will get copied into the completion list buffer.
+ (if minibuffer-completing-file-name
+ (with-current-buffer mainbuf
+ (setq default-directory (file-name-directory mbuf-contents))))
+ ;; If partial-completion-mode is on, point might not be after the
+ ;; last character in the minibuffer.
+ ;; FIXME: This still doesn't work if the text to be completed
+ ;; starts with a `-'.
+ (when (and partial-completion-mode (not (eobp)))
+ (setq mbuf-contents
+ (substring mbuf-contents 0 (- (point) (point-max)))))
+ (with-current-buffer standard-output
(completion-list-mode)
(make-local-variable 'completion-reference-buffer)
(setq completion-reference-buffer mainbuf)
- (if (eq minibuffer-completion-table 'read-file-name-internal)
+ (if minibuffer-completing-file-name
;; For file name completion,
;; use the number of chars before the start of the
;; last file name component.
(setq completion-base-size
- (save-excursion
- (set-buffer mainbuf)
- (goto-char (point-max))
- (skip-chars-backward (format "^%c" directory-sep-char))
- (- (point) (minibuffer-prompt-end))))
+ (with-current-buffer mainbuf
+ (save-excursion
+ (goto-char (point-max))
+ (skip-chars-backward completion-root-regexp)
+ (- (point) (minibuffer-prompt-end)))))
;; Otherwise, in minibuffer, the whole input is being completed.
- (save-match-data
- (if (string-match "\\` \\*Minibuf-[0-9]+\\*\\'"
- (buffer-name mainbuf))
+ (if (minibufferp mainbuf)
+ (if (and (symbolp minibuffer-completion-table)
+ (get minibuffer-completion-table 'completion-base-size-function))
+ (setq completion-base-size
+ (funcall (get minibuffer-completion-table 'completion-base-size-function)))
(setq completion-base-size 0))))
+ ;; Put faces on first uncommon characters and common parts.
+ (when completion-base-size
+ (let* ((common-string-length
+ (- (length mbuf-contents) completion-base-size))
+ (element-start (next-single-property-change
+ (point-min)
+ 'mouse-face))
+ (element-common-end
+ (and element-start
+ (+ (or element-start nil) common-string-length)))
+ (maxp (point-max)))
+ (while (and element-start (< element-common-end maxp))
+ (when (and (get-char-property element-start 'mouse-face)
+ (get-char-property element-common-end 'mouse-face))
+ (put-text-property element-start element-common-end
+ 'font-lock-face 'completions-common-part)
+ (put-text-property element-common-end (1+ element-common-end)
+ 'font-lock-face 'completions-first-difference))
+ (setq element-start (next-single-property-change
+ element-start
+ 'mouse-face))
+ (if element-start
+ (setq element-common-end (+ element-start common-string-length))))))
+ ;; Insert help string.
(goto-char (point-min))
(if (display-mouse-p)
(insert (substitute-command-keys
;; to the following event.
(defun event-apply-alt-modifier (ignore-prompt)
- "Add the Alt modifier to the following event.
+ "\\<function-key-map>Add the Alt modifier to the following event.
For example, type \\[event-apply-alt-modifier] & to enter Alt-&."
(vector (event-apply-modifier (read-event) 'alt 22 "A-")))
(defun event-apply-super-modifier (ignore-prompt)
- "Add the Super modifier to the following event.
+ "\\<function-key-map>Add the Super modifier to the following event.
For example, type \\[event-apply-super-modifier] & to enter Super-&."
(vector (event-apply-modifier (read-event) 'super 23 "s-")))
(defun event-apply-hyper-modifier (ignore-prompt)
- "Add the Hyper modifier to the following event.
+ "\\<function-key-map>Add the Hyper modifier to the following event.
For example, type \\[event-apply-hyper-modifier] & to enter Hyper-&."
(vector (event-apply-modifier (read-event) 'hyper 24 "H-")))
(defun event-apply-shift-modifier (ignore-prompt)
- "Add the Shift modifier to the following event.
+ "\\<function-key-map>Add the Shift modifier to the following event.
For example, type \\[event-apply-shift-modifier] & to enter Shift-&."
(vector (event-apply-modifier (read-event) 'shift 25 "S-")))
(defun event-apply-control-modifier (ignore-prompt)
- "Add the Ctrl modifier to the following event.
+ "\\<function-key-map>Add the Ctrl modifier to the following event.
For example, type \\[event-apply-control-modifier] & to enter Ctrl-&."
(vector (event-apply-modifier (read-event) 'control 26 "C-")))
(defun event-apply-meta-modifier (ignore-prompt)
- "Add the Meta modifier to the following event.
+ "\\<function-key-map>Add the Meta modifier to the following event.
For example, type \\[event-apply-meta-modifier] & to enter Meta-&."
(vector (event-apply-modifier (read-event) 'meta 27 "M-")))
(kp-decimal ?.)
(kp-divide ?/)
(kp-equal ?=)))
-
+\f
;;;;
;;;; forking a twin copy of a buffer.
;;;;
(let ((args (process-contact process t)))
(setq args (plist-put args :name newname))
(setq args (plist-put args :buffer
- (if (process-buffer process) (current-buffer))))
+ (if (process-buffer process)
+ (current-buffer))))
(apply 'make-network-process args))
(apply 'start-process newname
(if (process-buffer process) (current-buffer))
new-process (process-inherit-coding-system-flag process))
(set-process-filter new-process (process-filter process))
(set-process-sentinel new-process (process-sentinel process))
+ (set-process-plist new-process (copy-sequence (process-plist process)))
new-process)))
;; things to maybe add (currently partly covered by `funcall mode'):
;; - syntax-table
;; - overlays
(defun clone-buffer (&optional newname display-flag)
- "Create a twin copy of the current buffer.
-If NEWNAME is nil, it defaults to the current buffer's name;
-NEWNAME is modified by adding or incrementing <N> at the end as necessary.
+ "Create and return a twin copy of the current buffer.
+Unlike an indirect buffer, the new buffer can be edited
+independently of the old one (if it is not read-only).
+NEWNAME is the name of the new buffer. It may be modified by
+adding or incrementing <N> at the end as necessary to create a
+unique buffer name. If nil, it defaults to the name of the
+current buffer, with the proper suffix. If DISPLAY-FLAG is
+non-nil, the new buffer is shown with `pop-to-buffer'. Trying to
+clone a file-visiting buffer, or a buffer whose major mode symbol
+has a non-nil `no-clone' property, results in an error.
+
+Interactively, DISPLAY-FLAG is t and NEWNAME is the name of the
+current buffer with appropriate suffix. However, if a prefix
+argument is given, then the command prompts for NEWNAME in the
+minibuffer.
-If DISPLAY-FLAG is non-nil, the new buffer is shown with `pop-to-buffer'.
This runs the normal hook `clone-buffer-hook' in the new buffer
after it has been set up properly in other respects."
(interactive
Optional second arg NORECORD non-nil means do not put this buffer at
the front of the list of recently selected ones."
(interactive "bClone buffer in other window: ")
- (let ((popup-windows t))
+ (let ((pop-up-windows t))
(set-buffer buffer)
(clone-indirect-buffer nil t norecord)))
-(define-key ctl-x-4-map "c" 'clone-indirect-buffer-other-window)
-
-
-;;; Syntax stuff.
-
-(defconst syntax-code-table
- '((?\ 0 "whitespace")
- (?- 0 "whitespace")
- (?. 1 "punctuation")
- (?w 2 "word")
- (?_ 3 "symbol")
- (?\( 4 "open parenthesis")
- (?\) 5 "close parenthesis")
- (?\' 6 "expression prefix")
- (?\" 7 "string quote")
- (?$ 8 "paired delimiter")
- (?\\ 9 "escape")
- (?/ 10 "character quote")
- (?< 11 "comment start")
- (?> 12 "comment end")
- (?@ 13 "inherit")
- (nil 14 "comment fence")
- (nil 15 "string fence"))
- "Alist of forms (CHAR CODE DESCRIPTION) mapping characters to syntax info.
-CHAR is a character that is allowed as first char in the string
-specifying the syntax when calling `modify-syntax-entry'. CODE is the
-corresponing syntax code as it is stored in a syntax cell, and
-can be used as value of a `syntax-table' property.
-DESCRIPTION is the descriptive string for the syntax.")
-
-
+\f
;;; Handling of Backspace and Delete keys.
-(defcustom normal-erase-is-backspace nil
+(defcustom normal-erase-is-backspace
+ (and (not noninteractive)
+ (or (memq system-type '(ms-dos windows-nt))
+ (eq window-system 'mac)
+ (and (memq window-system '(x))
+ (fboundp 'x-backspace-delete-keys-p)
+ (x-backspace-delete-keys-p))
+ ;; If the terminal Emacs is running on has erase char
+ ;; set to ^H, use the Backspace key for deleting
+ ;; backward and, and the Delete key for deleting forward.
+ (and (null window-system)
+ (eq tty-erase-char ?\^H))))
"If non-nil, Delete key deletes forward and Backspace key deletes backward.
On window systems, the default value of this option is chosen
(if (interactive-p)
(message "Delete key deletes %s"
(if normal-erase-is-backspace "forward" "backward"))))
+\f
+(defvar vis-mode-saved-buffer-invisibility-spec nil
+ "Saved value of `buffer-invisibility-spec' when Visible mode is on.")
+(define-minor-mode visible-mode
+ "Toggle Visible mode.
+With argument ARG turn Visible mode on iff ARG is positive.
-;;; make-network-process wrappers
-
-(if (featurep 'make-network-process)
- (progn
-
-(defun open-network-stream (name buffer host service)
- "Open a TCP connection for a service to a host.
-Returns a subprocess-object to represent the connection.
-Input and output work as for subprocesses; `delete-process' closes it.
-Args are NAME BUFFER HOST SERVICE.
-NAME is name for process. It is modified if necessary to make it unique.
-BUFFER is the buffer (or buffer-name) to associate with the process.
- Process output goes at end of that buffer, unless you specify
- an output stream or filter function to handle the output.
- BUFFER may be also nil, meaning that this process is not associated
- with any buffer
-Third arg is name of the host to connect to, or its IP address.
-Fourth arg SERVICE is name of the service desired, or an integer
-specifying a port number to connect to."
- (make-network-process :name name :buffer buffer
- :host host :service service))
-
-(defun open-network-stream-nowait (name buffer host service &optional sentinel filter)
- "Initiate connection to a TCP connection for a service to a host.
-It returns nil if non-blocking connects are not supported; otherwise,
-it returns a subprocess-object to represent the connection.
-
-This function is similar to `open-network-stream', except that this
-function returns before the connection is established. When the
-connection is completed, the sentinel function will be called with
-second arg matching `open' (if successful) or `failed' (on error).
-
-Args are NAME BUFFER HOST SERVICE SENTINEL FILTER.
-NAME, BUFFER, HOST, and SERVICE are as for `open-network-stream'.
-Optional args, SENTINEL and FILTER specifies the sentinel and filter
-functions to be used for this network stream."
- (if (featurep 'make-network-process '(:nowait t))
- (make-network-process :name name :buffer buffer :nowait t
- :host host :service service
- :filter filter :sentinel sentinel)))
-
-(defun open-network-stream-server (name buffer service &optional sentinel filter)
- "Create a network server process for a TCP service.
-It returns nil if server processes are not supported; otherwise,
-it returns a subprocess-object to represent the server.
-
-When a client connects to the specified service, a new subprocess
-is created to handle the new connection, and the sentinel function
-is called for the new process.
-
-Args are NAME BUFFER SERVICE SENTINEL FILTER.
-NAME is name for the server process. Client processes are named by
-appending the ip-address and port number of the client to NAME.
-BUFFER is the buffer (or buffer-name) to associate with the server
-process. Client processes will not get a buffer if a process filter
-is specified or BUFFER is nil; otherwise, a new buffer is created for
-the client process. The name is similar to the process name.
-Third arg SERVICE is name of the service desired, or an integer
-specifying a port number to connect to. It may also be t to selected
-an unused port number for the server.
-Optional args, SENTINEL and FILTER specifies the sentinel and filter
-functions to be used for the client processes; the server process
-does not use these function."
- (if (featurep 'make-network-process '(:server t))
- (make-network-process :name name :buffer buffer
- :service service :server t :noquery t)))
-
-)) ;; (featurep 'make-network-process)
-
-
-;; compatibility
-
-(defun process-kill-without-query (process &optional flag)
- "Say no query needed if PROCESS is running when Emacs is exited.
-Optional second argument if non-nil says to require a query.
-Value is t if a query was formerly required.
-New code should not use this function; use `process-query-on-exit-flag'
-or `set-process-query-on-exit-flag' instead."
- (let ((old (process-query-on-exit-flag process)))
- (set-process-query-on-exit-flag process nil)
- old))
-
-;;; Misc
-
-(defun byte-compiling-files-p ()
- "Return t if currently byte-compiling files."
- (and (boundp 'byte-compile-current-file)
- (stringp byte-compile-current-file)))
-
-
+Enabling Visible mode makes all invisible text temporarily visible.
+Disabling Visible mode turns off that effect. Visible mode
+works by saving the value of `buffer-invisibility-spec' and setting it to nil."
+ :lighter " Vis"
+ :group 'editing-basics
+ (when (local-variable-p 'vis-mode-saved-buffer-invisibility-spec)
+ (setq buffer-invisibility-spec vis-mode-saved-buffer-invisibility-spec)
+ (kill-local-variable 'vis-mode-saved-buffer-invisibility-spec))
+ (when visible-mode
+ (set (make-local-variable 'vis-mode-saved-buffer-invisibility-spec)
+ buffer-invisibility-spec)
+ (setq buffer-invisibility-spec nil)))
+\f
;; Minibuffer prompt stuff.
;(defun minibuffer-prompt-modification (start end)
; (message "You cannot modify the prompt")))
;
;
-;(setq minibuffer-prompt-properties
+;(setq minibuffer-prompt-properties
; (list 'modification-hooks '(minibuffer-prompt-modification)
; 'insert-in-front-hooks '(minibuffer-prompt-insertion)))
-;
+;
+
+(provide 'simple)
+;; arch-tag: 24af67c0-2a49-44f6-b3b1-312d8b570dfd
;;; simple.el ends here
HCoop / bpt / emacs.git / blobdiff