;;; 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, 86, 87, 93, 94, 95, 96, 97, 98, 99,
+;; 2000, 01, 02, 03, 04
;; Free Software Foundation, Inc.
;; Maintainer: FSF
(defgroup killing nil
- "Killing and yanking commands"
+ "Killing and yanking commands."
:group 'editing)
(defgroup paren-matching nil
(setq list (cdr list)))
(switch-to-buffer found)))
+;;; next-error support framework
+(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 extra-test)
+ "Test if BUFFER is a next-error capable buffer."
+ (with-current-buffer buffer
+ (or (and extra-test (funcall extra-test))
+ next-error-function)))
+
+;; Return a next-error capable buffer according to the following rules:
+;; 1. If the current buffer is a next-error capable buffer, return it.
+;; 2. If one window on the selected frame displays such buffer, return it.
+;; 3. If next-error-last-buffer is set to a live buffer, use that.
+;; 4. Otherwise, look for a next-error capable buffer in a buffer list.
+;; 5. Signal an error if there are none.
+(defun next-error-find-buffer (&optional other-buffer extra-test)
+ (if (and (not other-buffer)
+ (next-error-buffer-p (current-buffer) extra-test))
+ ;; The current buffer is a next-error capable buffer.
+ (current-buffer)
+ (or
+ (let ((window-buffers
+ (delete-dups
+ (delq nil
+ (mapcar (lambda (w)
+ (and (next-error-buffer-p (window-buffer w) extra-test)
+ (window-buffer w)))
+ (window-list))))))
+ (if other-buffer
+ (setq window-buffers (delq (current-buffer) window-buffers)))
+ (if (eq (length window-buffers) 1)
+ (car window-buffers)))
+ (if (and next-error-last-buffer (buffer-name next-error-last-buffer)
+ (next-error-buffer-p next-error-last-buffer extra-test)
+ (or (not other-buffer) (not (eq next-error-last-buffer
+ (current-buffer)))))
+ next-error-last-buffer
+ (let ((buffers (buffer-list)))
+ (while (and buffers (or (not (next-error-buffer-p (car buffers) extra-test))
+ (and other-buffer
+ (eq (car buffers) (current-buffer)))))
+ (setq buffers (cdr buffers)))
+ (if buffers
+ (car buffers)
+ (or (and other-buffer
+ (next-error-buffer-p (current-buffer) extra-test)
+ ;; The current buffer is a next-error capable buffer.
+ (progn
+ (if other-buffer
+ (message "This is the only next-error capable buffer."))
+ (current-buffer)))
+ (error "No next-error capable buffer found"))))))))
+
+(defun next-error (arg &optional 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.
+
+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)
+
+(define-key ctl-x-map "`" 'next-error)
+
+(defun previous-error (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 (- n)))
+
+(defun first-error (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 (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")
+ (next-error n)
+ (pop-to-buffer next-error-last-buffer))
+
+(defun previous-error-no-select (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 (- n)))
+
+;;;
+
(defun fundamental-mode ()
"Major mode not specialized for anything in particular.
Other major modes are defined by comparison with this one."
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)
(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.
(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 (point-min))
- (message "line %d (narrowed line %d)"
- (1+ (count-lines (point-min) (point)))
- (1+ (count-lines start (point))))
- (message "Line %d" (1+ (count-lines (point-min) (point)))))))))
+ (let ((opoint (point)) (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
(if (or (not coding)
(eq (coding-system-type coding) t))
(setq coding default-buffer-file-coding-system))
- (if (not (char-valid-p char))
+ (if (eq (char-charset char) 'eight-bit)
(setq encoding-msg
- (format "(0%o, %d, 0x%x, invalid)" char char char))
+ (format "(0%o, %d, 0x%x, raw-byte)" char char char))
(setq encoded (and (>= char 128) (encode-coding-char char coding)))
(setq encoding-msg
(if encoded
: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)
+ (and (boundp 'edebug-active) edebug-active)))
+ (let ((char-string
+ (if (or (and (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
- (unwind-protect
- (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 ((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.
(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
;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.")
+
+(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.")
+
(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 (if (and transient-mark-mode mark-active)
- "Undo in region!"
- "Undo!")))
+ ;; 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 (eq last-command 'undo)
- (if (if transient-mark-mode mark-active (and arg (not (numberp arg))))
+ (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 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, so we can skip them later on.
+ ;; I don't know how to do that in the undo-in-region case.
+ (unless undo-in-region
+ (puthash buffer-undo-list 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))
(and modified (not (buffer-modified-p))
(delete-auto-save-file-if-necessary recent-save))))
+(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)))
+;; Richard said that we should not use C-x <uppercase letter> and I have
+;; no idea whereas to bind it. Any suggestion welcome. -stef
+;; (define-key ctl-x-map "U" 'undo-only)
+
(defvar pending-undo-list nil
"Within a run of consecutive undo commands, list remaining to be undone.")
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 (format "No further undo information%s"
- (if (and transient-mark-mode mark-active)
+ (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))))
(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)
nil shell-command-switch command)))
;; Report the output.
(with-current-buffer buffer
- (setq mode-line-process
+ (setq mode-line-process
(cond ((null exit-status)
" - Error")
((stringp exit-status)
`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
;;;; Window system cut and paste hooks.
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)))
(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.
;; 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)
;; 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)
- "*Text properties to discard when yanking."
+ '(read-only invisible intangible field mouse-face help-echo local-map keymap
+ yank-handler)
+ "*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 'editing
+ :group 'killing
:version "21.4")
(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 (arg)
+(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 (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))
(insert-for-yank (current-kill arg))
;; Set the window start back where it was in the yank command,
(push-mark (point))
(insert-for-yank (current-kill (cond
((listp arg) 0)
- ((eq arg '-) -1)
+ ((eq arg '-) -2)
(t (1- arg)))))
(if (consp arg)
;; This is like exchange-point-and-mark, but doesn't activate the mark.
(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
(save-excursion
(end-of-visible-line) (point))))
(if (or (save-excursion
- (skip-chars-forward " \t" end)
+ ;; 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.
(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)))
(unless (bobp)
(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 first nil)
- (setq arg (1+ arg)))
+ (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)))
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)
(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. Immediately repeating the
-command activates `transient-mark-mode' temporarily.
+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'\).
-With argument, jump to mark, and pop a new position for mark off the ring
-\(does not affect global mark ring\). Repeating the command without
-an argument jumps to the next position off the mark ring.
+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."
(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)
- (if (and (consp arg) (> (prefix-numeric-value arg) 4))
- (push-mark-command nil)
- (setq this-command 'pop-to-mark-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))
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))
+ (deactivate-mark)
+ (move-marker (car mark-ring) nil)
+ (if (null (mark t)) (ding))
+ (setq mark-ring (cdr mark-ring))))
(defalias 'exchange-dot-and-mark 'exchange-point-and-mark)
(defun exchange-point-and-mark (&optional arg)
With prefix arg, `transient-mark-mode' is enabled temporarily."
(interactive "P")
(if arg
- (if mark-active
+ (if mark-active
(if (null transient-mark-mode)
(setq transient-mark-mode 'lambda))
(setq arg nil)))
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))
+ (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.
`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))
+ (or arg (setq arg 1))
(if (interactive-p)
(condition-case nil
(line-move (- arg))
(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)))
+ (forward-word (- (or arg 1))))
(defun mark-word (arg)
"Set mark arg words away from point.
(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.
+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))
(not (and fill-indent-according-to-mode
(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)))
- (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)))))
+ (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
(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
When Column Number mode is enabled, the column number appears
in the mode line."
: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)))
+ (save-excursion
+ (goto-char blinkpos)
+ (not (looking-at "\\s$")))
+ (setq matching-paren
+ (or (and parse-sexp-lookup-properties
+ (let ((prop (get-text-property blinkpos 'syntax-table)))
+ (and (consp prop)
+ (eq (car prop) 4)
+ (cdr prop))))
+ (matching-paren (char-after blinkpos)))
+ 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.
(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"))
(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%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)))
-
+ (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.
(if make-local
(make-local-variable var))
-
+
(set var val)
;; Force a thorough redisplay for the case that the variable
;; 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 (string-match "\\` \\*Minibuf-[0-9]+\\*\\'"
- (buffer-name buffer))))
+ (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")
- (unless (run-hook-with-args-until-success
+ (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.
;; 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)
(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))))
+ (with-current-buffer standard-output
(completion-list-mode)
(make-local-variable 'completion-reference-buffer)
(setq completion-reference-buffer mainbuf)
- (if (memq minibuffer-completion-table
- '(ffap-read-file-or-url-internal 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 "^/")
- (- (point) (minibuffer-prompt-end))))
+ (with-current-buffer mainbuf
+ (save-excursion
+ (goto-char (point-max))
+ (skip-chars-backward "^/")
+ (- (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))
- (setq completion-base-size 0))))
+ (if (minibufferp mainbuf)
+ (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
+ (+ (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-")))
(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
(if (interactive-p)
(message "Delete key deletes %s"
(if normal-erase-is-backspace "forward" "backward"))))
-
-
+\f
+(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 "21.4")
+\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.
+
+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"
+ (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