X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/7cd330deb66863a144d7e2c36210f13d10db5245..a3dae87a1b5405d2bffde7c2d829a5dbfc7ff274:/lisp/simple.el diff --git a/lisp/simple.el b/lisp/simple.el index f19525aba4..fe46e36fda 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -28,13 +28,14 @@ ;;; Code: -;; This is for lexical-let in apply-partially. -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) ;For define-minor-mode. (declare-function widget-convert "wid-edit" (type &rest args)) (declare-function shell-mode "shell" ()) +;;; From compile.el (defvar compilation-current-error) +(defvar compilation-context-lines) (defcustom idle-update-delay 0.5 "Idle time delay before updating various things on the screen. @@ -51,60 +52,6 @@ wait this many seconds after Emacs becomes idle before doing an update." (defgroup paren-matching nil "Highlight (un)matching of parens and expressions." :group 'matching) - -(defun get-next-valid-buffer (list &optional buffer visible-ok frame) - "Search LIST for a valid buffer to display in FRAME. -Return nil when all buffers in LIST are undesirable for display, -otherwise return the first suitable buffer in LIST. - -Buffers not visible in windows are preferred to visible buffers, -unless VISIBLE-OK is non-nil. -If the optional argument FRAME is nil, it defaults to the selected frame. -If BUFFER is non-nil, ignore occurrences of that buffer in LIST." - ;; This logic is more or less copied from other-buffer. - (setq frame (or frame (selected-frame))) - (let ((pred (frame-parameter frame 'buffer-predicate)) - found buf) - (while (and (not found) list) - (setq buf (car list)) - (if (and (not (eq buffer buf)) - (buffer-live-p buf) - (or (null pred) (funcall pred buf)) - (not (eq (aref (buffer-name buf) 0) ?\s)) - (or visible-ok (null (get-buffer-window buf 'visible)))) - (setq found buf) - (setq list (cdr list)))) - (car list))) - -(defun last-buffer (&optional buffer visible-ok frame) - "Return the last buffer in FRAME's buffer list. -If BUFFER is the last buffer, return the preceding buffer instead. -Buffers not visible in windows are preferred to visible buffers, -unless optional argument VISIBLE-OK is non-nil. -Optional third argument FRAME nil or omitted means use the -selected frame's buffer list. -If no such buffer exists, return the buffer `*scratch*', creating -it if necessary." - (setq frame (or frame (selected-frame))) - (or (get-next-valid-buffer (nreverse (buffer-list frame)) - buffer visible-ok frame) - (get-buffer "*scratch*") - (let ((scratch (get-buffer-create "*scratch*"))) - (set-buffer-major-mode scratch) - scratch))) - -(defun next-buffer () - "Switch to the next buffer in cyclic order." - (interactive) - (let ((buffer (current-buffer))) - (switch-to-buffer (other-buffer buffer t)) - (bury-buffer buffer))) - -(defun previous-buffer () - "Switch to the previous buffer in cyclic order." - (interactive) - (switch-to-buffer (last-buffer (current-buffer) t))) - ;;; next-error support framework @@ -304,8 +251,8 @@ runs `next-error-hook' with `run-hooks', and 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." +To control which errors are matched, customize the variable +`compilation-error-regexp-alist'." (interactive "P") (if (consp arg) (setq reset t arg nil)) (when (setq next-error-last-buffer (next-error-find-buffer)) @@ -637,7 +584,9 @@ If the region is active, only delete whitespace within the region." (if (looking-at ".*\f") (goto-char (match-end 0)))) (delete-region (point) (match-end 0))) - (set-marker end-marker nil))))) + (set-marker end-marker nil)))) + ;; Return nil for the benefit of `write-file-functions'. + nil) (defun newline-and-indent () "Insert a newline, then indent according to major mode. @@ -778,7 +727,7 @@ If N is negative, delete newlines as well." (n (abs n))) (skip-chars-backward skip-characters) (constrain-to-field nil orig-pos) - (dotimes (i (or n 1)) + (dotimes (i n) (if (= (following-char) ?\s) (forward-char 1) (insert ?\s))) @@ -888,8 +837,8 @@ the end of the line." (memq (char-before) '(?\t ?\n)) (eobp) (eq (char-after) ?\n))) - (let* ((ocol (current-column)) - (val (delete-char (- n) killflag))) + (let ((ocol (current-column))) + (delete-char (- n) killflag) (save-excursion (insert-char ?\s (- ocol (current-column)) nil)))) ;; Otherwise, do simple deletion. @@ -951,10 +900,11 @@ rather than line counts." (save-excursion (skip-chars-backward "0-9") (if (looking-at "[0-9]") - (buffer-substring-no-properties - (point) - (progn (skip-chars-forward "0-9") - (point)))))) + (string-to-number + (buffer-substring-no-properties + (point) + (progn (skip-chars-forward "0-9") + (point))))))) ;; Decide if we're switching buffers. (buffer (if (consp current-prefix-arg) @@ -964,13 +914,11 @@ rather than line counts." (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) + (list (read-number (format (if default "Goto line%s (%s): " + "Goto line%s: ") + buffer-prompt + default) + default) buffer)))) ;; Switch to the desired buffer, one way or another. (if buffer @@ -998,7 +946,7 @@ When called interactively, the word count is printed in echo area." (goto-char (point-min)) (while (forward-word 1) (setq count (1+ count))))) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "Region has %d words" count)) count)) @@ -1147,11 +1095,15 @@ in *Help* buffer. See also the command `describe-char'." ;; Initialize read-expression-map. It is defined at C level. (let ((m (make-sparse-keymap))) (define-key m "\M-\t" 'lisp-complete-symbol) + ;; Might as well bind TAB to completion, since inserting a TAB char is much + ;; too rarely useful. + (define-key m "\t" 'lisp-complete-symbol) (set-keymap-parent m minibuffer-local-map) (setq read-expression-map m)) (defvar minibuffer-completing-symbol nil "Non-nil means completing a Lisp symbol in the minibuffer.") +(make-obsolete-variable 'minibuffer-completing-symbol nil "24.1" 'get) (defvar minibuffer-default nil "The current default value or list of default values in the minibuffer. @@ -1201,6 +1153,8 @@ display the result of expression evaluation." (defun eval-expression (eval-expression-arg &optional eval-expression-insert-value) "Evaluate EVAL-EXPRESSION-ARG and print value in the echo area. +When called interactively, read an Emacs Lisp expression and +evaluate it. Value is also consed on to front of the variable `values'. Optional argument EVAL-EXPRESSION-INSERT-VALUE non-nil (interactively, with prefix argument) means insert the result into the current buffer @@ -1218,12 +1172,12 @@ this command arranges for all errors to enter the debugger." current-prefix-arg)) (if (null eval-expression-debug-on-error) - (setq values (cons (eval eval-expression-arg) values)) + (push (eval eval-expression-arg lexical-binding) values) (let ((old-value (make-symbol "t")) new-value) ;; Bind debug-on-error to something unique so that we can ;; detect when evaled code changes it. (let ((debug-on-error old-value)) - (setq values (cons (eval eval-expression-arg) values)) + (push (eval eval-expression-arg lexical-binding) values) (setq new-value debug-on-error)) ;; If evaled code has changed the value of debug-on-error, ;; propagate that change to the global binding. @@ -1364,7 +1318,7 @@ in this use of the minibuffer.") (defun minibuffer-history-initialize () (setq minibuffer-text-before-history nil)) -(defun minibuffer-avoid-prompt (new old) +(defun minibuffer-avoid-prompt (_new _old) "A point-motion hook for the minibuffer, that moves point out of the prompt." (constrain-to-field nil (point-max))) @@ -1730,7 +1684,7 @@ in the search status stack." `(lambda (cmd) (minibuffer-history-isearch-pop-state cmd ,minibuffer-history-position))) -(defun minibuffer-history-isearch-pop-state (cmd hist-pos) +(defun minibuffer-history-isearch-pop-state (_cmd hist-pos) "Restore the minibuffer history search state. Go to the history element by the absolute history position HIST-POS." (goto-history-element hist-pos)) @@ -1922,7 +1876,7 @@ we stop and ignore all further elements." (undo-list (list nil)) undo-adjusted-markers some-rejected - undo-elt undo-elt temp-undo-list delta) + undo-elt temp-undo-list delta) (while undo-list-copy (setq undo-elt (car undo-list-copy)) (let ((keep-this @@ -2157,23 +2111,12 @@ to the end of the list of defaults just after the default value." (append minibuffer-default commands) (cons minibuffer-default commands)))) -(defvar shell-delimiter-argument-list) -(defvar shell-file-name-chars) -(defvar shell-file-name-quote-list) - -(defun minibuffer-complete-shell-command () - "Dynamically complete shell command at point." - (interactive) - (require 'shell) - (let ((comint-delimiter-argument-list shell-delimiter-argument-list) - (comint-file-name-chars shell-file-name-chars) - (comint-file-name-quote-list shell-file-name-quote-list)) - (run-hook-with-args-until-success 'shell-dynamic-complete-functions))) +(declare-function shell-completion-vars "shell" ()) (defvar minibuffer-local-shell-command-map (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) - (define-key map "\t" 'minibuffer-complete-shell-command) + (define-key map "\t" 'completion-at-point) map) "Keymap used for completing shell commands in minibuffer.") @@ -2182,8 +2125,10 @@ to the end of the list of defaults just after the default value." The arguments are the same as the ones of `read-from-minibuffer', except READ and KEYMAP are missing and HIST defaults to `shell-command-history'." + (require 'shell) (minibuffer-with-setup-hook (lambda () + (shell-completion-vars) (set (make-local-variable 'minibuffer-default-add-function) 'minibuffer-default-add-shell-commands)) (apply 'read-from-minibuffer prompt initial-contents @@ -2589,7 +2534,11 @@ specifies the value of ERROR-BUFFER." (let ((output (if (and error-file (< 0 (nth 7 (file-attributes error-file)))) - "some error output" + (format "some error output%s" + (if shell-command-default-error-buffer + (format " to the \"%s\" buffer" + shell-command-default-error-buffer) + "")) "no output"))) (cond ((null exit-status) (message "(Shell command failed with error)")) @@ -2628,7 +2577,7 @@ specifies the value of ERROR-BUFFER." (with-output-to-string (with-current-buffer standard-output - (call-process shell-file-name nil t nil shell-command-switch command)))) + (process-file 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. @@ -2689,7 +2638,97 @@ support pty association, if PROGRAM is nil." (let ((fh (find-file-name-handler default-directory 'start-file-process))) (if fh (apply fh 'start-file-process name buffer program program-args) (apply 'start-process name buffer program program-args)))) - + +;;;; Process menu + +(defvar tabulated-list-format) +(defvar tabulated-list-entries) +(defvar tabulated-list-sort-key) +(declare-function tabulated-list-init-header "tabulated-list" ()) +(declare-function tabulated-list-print "tabulated-list" + (&optional remember-pos)) + +(defvar process-menu-query-only nil) + +(define-derived-mode process-menu-mode tabulated-list-mode "Process Menu" + "Major mode for listing the processes called by Emacs." + (setq tabulated-list-format [("Process" 15 t) + ("Status" 7 t) + ("Buffer" 15 t) + ("TTY" 12 t) + ("Command" 0 t)]) + (make-local-variable 'process-menu-query-only) + (setq tabulated-list-sort-key (cons "Process" nil)) + (add-hook 'tabulated-list-revert-hook 'list-processes--refresh nil t) + (tabulated-list-init-header)) + +(defun list-processes--refresh () + "Recompute the list of processes for the Process List buffer." + (setq tabulated-list-entries nil) + (dolist (p (process-list)) + (when (or (not process-menu-query-only) + (process-query-on-exit-flag p)) + (let* ((buf (process-buffer p)) + (type (process-type p)) + (name (process-name p)) + (status (symbol-name (process-status p))) + (buf-label (if (buffer-live-p buf) + `(,(buffer-name buf) + face link + help-echo ,(concat "Visit buffer `" + (buffer-name buf) "'") + follow-link t + process-buffer ,buf + action process-menu-visit-buffer) + "--")) + (tty (or (process-tty-name p) "--")) + (cmd + (if (memq type '(network serial)) + (let ((contact (process-contact p t))) + (if (eq type 'network) + (format "(%s %s)" + (if (plist-get contact :type) + "datagram" + "network") + (if (plist-get contact :server) + (format "server on %s" + (plist-get contact :server)) + (format "connection to %s" + (plist-get contact :host)))) + (format "(serial port %s%s)" + (or (plist-get contact :port) "?") + (let ((speed (plist-get contact :speed))) + (if speed + (format " at %s b/s" speed) + ""))))) + (mapconcat 'identity (process-command p) " ")))) + (push (list p (vector name status buf-label tty cmd)) + tabulated-list-entries))))) + +(defun process-menu-visit-buffer (button) + (display-buffer (button-get button 'process-buffer))) + +(defun list-processes (&optional query-only buffer) + "Display a list of all processes. +If optional argument QUERY-ONLY is non-nil, only processes with +the query-on-exit flag set are listed. +Any process listed as exited or signaled is actually eliminated +after the listing is made. +Optional argument BUFFER specifies a buffer to use, instead of +\"*Process List\". +The return value is always nil." + (interactive) + (or (fboundp 'process-list) + (error "Asynchronous subprocesses are not supported on this system")) + (unless (bufferp buffer) + (setq buffer (get-buffer-create "*Process List*"))) + (with-current-buffer buffer + (process-menu-mode) + (setq process-menu-query-only query-only) + (list-processes--refresh) + (tabulated-list-print)) + (display-buffer buffer) + nil) (defvar universal-argument-map (let ((map (make-sparse-keymap))) @@ -2727,25 +2766,21 @@ support pty association, if PROGRAM is nil." `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 +(defvar saved-overriding-map t "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 +(defun save&set-overriding-map (map) + "Set `overriding-terminal-local-map' to MAP." + (when (eq saved-overriding-map t) (setq saved-overriding-map overriding-terminal-local-map) - (setq overriding-terminal-local-map universal-argument-map) - (setq overriding-map-is-bound t))) + (setq overriding-terminal-local-map map))) (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)) + (setq saved-overriding-map t)) (defun universal-argument () "Begin a numeric argument for the following command. @@ -2760,7 +2795,7 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]." (interactive) (setq prefix-arg (list 4)) (setq universal-argument-num-events (length (this-command-keys))) - (ensure-overriding-map-is-bound)) + (save&set-overriding-map universal-argument-map)) ;; 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. @@ -2785,7 +2820,7 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]." (t (setq prefix-arg '-))) (setq universal-argument-num-events (length (this-command-keys))) - (ensure-overriding-map-is-bound)) + (save&set-overriding-map universal-argument-map)) (defun digit-argument (arg) "Part of the numeric argument for the next command. @@ -2804,7 +2839,7 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]." (t (setq prefix-arg digit)))) (setq universal-argument-num-events (length (this-command-keys))) - (ensure-overriding-map-is-bound)) + (save&set-overriding-map universal-argument-map)) ;; For backward compatibility, minus with no modifiers is an ordinary ;; command if digits have already been entered. @@ -2827,51 +2862,6 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]." (reset-this-command-lengths) (restore-overriding-map)) -;; This function is here rather than in subr.el because it uses CL. -(defmacro with-wrapper-hook (var args &rest body) - "Run BODY wrapped with the VAR hook. -VAR is a special hook: its functions are called with a first argument -which is the \"original\" code (the BODY), so the hook function can wrap -the original function, or call it any number of times (including not calling -it at all). This is similar to an `around' advice. -VAR is normally a symbol (a variable) in which case it is treated like -a hook, with a buffer-local and a global part. But it can also be an -arbitrary expression. -ARGS is a list of variables which will be passed as additional arguments -to each function, after the initial argument, and which the first argument -expects to receive when called." - (declare (indent 2) (debug t)) - ;; We need those two gensyms because CL's lexical scoping is not available - ;; for function arguments :-( - (let ((funs (make-symbol "funs")) - (global (make-symbol "global")) - (argssym (make-symbol "args"))) - ;; Since the hook is a wrapper, the loop has to be done via - ;; recursion: a given hook function will call its parameter in order to - ;; continue looping. - `(labels ((runrestofhook (,funs ,global ,argssym) - ;; `funs' holds the functions left on the hook and `global' - ;; holds the functions left on the global part of the hook - ;; (in case the hook is local). - (lexical-let ((funs ,funs) - (global ,global)) - (if (consp funs) - (if (eq t (car funs)) - (runrestofhook - (append global (cdr funs)) nil ,argssym) - (apply (car funs) - (lambda (&rest ,argssym) - (runrestofhook (cdr funs) global ,argssym)) - ,argssym)) - ;; Once there are no more functions on the hook, run - ;; the original body. - (apply (lambda ,args ,@body) ,argssym))))) - (runrestofhook ,var - ;; The global part of the hook, if any. - ,(if (symbolp var) - `(if (local-variable-p ',var) - (default-value ',var))) - (list ,@args))))) (defvar filter-buffer-substring-functions nil "Wrapper hook around `filter-buffer-substring'. @@ -3067,10 +3057,11 @@ If `interprogram-cut-function' is set, pass the resulting kill to it." (defun current-kill (n &optional do-not-move) "Rotate the yanking point by N places, and then return that kill. -If N is zero, `interprogram-paste-function' is set, and calling -it returns a string or list of strings, then that string (or -list) is added to the front of the kill ring and the string (or -first string in the list) is returned as the latest kill. +If N is zero and `interprogram-paste-function' is set to a +function that returns a string or a list of strings, and if that +function doesn't return nil, then that string (or list) is added +to the front of the kill ring and the string (or first string in +the list) is returned as the latest kill. If N is not zero, and if `yank-pop-change-selection' is non-nil, use `interprogram-cut-function' to transfer the @@ -3390,16 +3381,16 @@ and KILLP is t if a prefix arg was specified." (delete-char 1))) (forward-char -1) (setq count (1- count)))))) - (delete-backward-char - (let ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t") + (let* ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t") ((eq backward-delete-char-untabify-method 'all) - " \t\n\r")))) - (if skip - (let ((wh (- (point) (save-excursion (skip-chars-backward skip) - (point))))) - (+ arg (if (zerop wh) 0 (1- wh)))) - arg)) - killp)) + " \t\n\r"))) + (n (if skip + (let ((wh (- (point) (save-excursion (skip-chars-backward skip) + (point))))) + (+ arg (if (zerop wh) 0 (1- wh)))) + arg))) + ;; Avoid warning about delete-backward-char + (with-no-warnings (delete-backward-char n killp)))) (defun zap-to-char (arg char) "Kill up to and including ARGth occurrence of CHAR. @@ -4360,7 +4351,7 @@ If nil, `line-move' moves point by logical lines." ;; This is the guts of next-line and previous-line. ;; Arg says how many lines to move. ;; The value is t if we can move the specified number of lines. -(defun line-move-1 (arg &optional noerror to-end) +(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) @@ -5134,8 +5125,8 @@ Returns t if it really did any work." (or (null fill-prefix) (string= fill-prefix ""))) (let ((prefix (fill-context-prefix - (save-excursion (backward-paragraph 1) (point)) - (save-excursion (forward-paragraph 1) (point))))) + (save-excursion (fill-forward-paragraph -1) (point)) + (save-excursion (fill-forward-paragraph 1) (point))))) (and prefix (not (equal prefix "")) ;; Use auto-indentation rather than a guessed empty prefix. (not (and fill-indent-according-to-mode @@ -5247,14 +5238,16 @@ Some major modes set this.") ;; auto-fill-function to nil in a file-local setting is safe and ;; can be useful to prevent auto-filling. (put 'auto-fill-function 'safe-local-variable 'null) -;; FIXME: turn into a proper minor mode. -;; Add a global minor mode version of it. + (define-minor-mode auto-fill-mode "Toggle Auto Fill mode. With ARG, turn Auto Fill mode on if and only if ARG is positive. In Auto Fill mode, inserting a space at a column beyond `current-fill-column' automatically breaks the line at a previous space. +When `auto-fill-mode' is on, the `auto-fill-function' variable is +non-`nil'. + The value of `normal-auto-fill-function' specifies the function to use for `auto-fill-function' when turning Auto Fill mode on." :variable (eq auto-fill-function normal-auto-fill-function)) @@ -5316,11 +5309,12 @@ The variable `selective-display' has a separate value for each buffer." (defvaralias 'indicate-unused-lines 'indicate-empty-lines) (defun toggle-truncate-lines (&optional arg) - "Toggle whether to fold or truncate long lines for the current buffer. + "Toggle truncating of long lines for the current buffer. +When truncating is off, long lines are folded. With prefix argument ARG, truncate long lines if ARG is positive, -otherwise don't truncate them. Note that in side-by-side windows, -this command has no effect if `truncate-partial-width-windows' -is non-nil." +otherwise fold them. Note that in side-by-side windows, this +command has no effect if `truncate-partial-width-windows' is +non-nil." (interactive "P") (setq truncate-lines (if (null arg) @@ -5530,11 +5524,11 @@ The function should return non-nil if the two tokens do not match.") (mismatch (if blinkpos (if (minibufferp) - (minibuffer-message " [Mismatched parentheses]") + (minibuffer-message "Mismatched parentheses") (message "Mismatched parentheses")) (if (minibufferp) - (minibuffer-message " [Unmatched parenthesis]") - (message "Unmatched parenthesis")))) + (minibuffer-message "No matching parenthesis found") + (message "No matching parenthesis found")))) ((not blinkpos) nil) ((pos-visible-in-window-p blinkpos) ;; Matching open within window, temporarily move to blinkpos but only @@ -5617,7 +5611,8 @@ At top-level, as an editor command, this simply beeps." (if (fboundp 'kmacro-keyboard-quit) (kmacro-keyboard-quit)) (setq defining-kbd-macro nil) - (signal 'quit nil)) + (let ((debug-on-quit nil)) + (signal 'quit nil))) (defvar buffer-quit-function nil "Function to call to \"quit\" the current buffer, or nil if none. @@ -5723,7 +5718,10 @@ appears to have customizations applying to the old default, :group 'mail) (defun rfc822-goto-eoh () - ;; Go to header delimiter line in a mail message, following RFC822 rules + "If the buffer starts with a mail header, move point to the header's end. +Otherwise, moves to `point-min'. +The end of the header is the start of the next line, if there is one, +else the end of the last line. This function obeys RFC822." (goto-char (point-min)) (when (re-search-forward "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) @@ -5923,6 +5921,12 @@ Its value is a list of the form (START END) where START is the place where the completion should be inserted and END (if non-nil) is the end of the text to replace. If END is nil, point is used instead.") +(defvar completion-list-insert-choice-function #'completion--replace + "Function to use to insert the text chosen in *Completions*. +Called with 3 arguments (BEG END TEXT), it should replace the text +between BEG and END with TEXT. Expected to be set buffer-locally +in the *Completions* buffer.") + (defvar completion-base-size nil "Number of chars before point not involved in completion. This is a local variable in the completion list buffer. @@ -5986,26 +5990,30 @@ With prefix argument N, move N items (negative N means move backward)." ;; In case this is run via the mouse, give temporary modes such as ;; isearch a chance to turn off. (run-hooks 'mouse-leave-buffer-hook) - (let (buffer base-size base-position choice) - (with-current-buffer (window-buffer (posn-window (event-start event))) - (setq buffer completion-reference-buffer) - (setq base-size completion-base-size) - (setq base-position completion-base-position) - (save-excursion - (goto-char (posn-point (event-start event))) - (let (beg end) - (if (and (not (eobp)) (get-text-property (point) 'mouse-face)) - (setq end (point) beg (1+ (point)))) - (if (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face)) - (setq end (1- (point)) beg (point))) - (if (null beg) - (error "No completion here")) - (setq beg (previous-single-property-change beg 'mouse-face)) - (setq end (or (next-single-property-change end 'mouse-face) - (point-max))) - (setq choice (buffer-substring-no-properties beg end))))) - - (let ((owindow (selected-window))) + (with-current-buffer (window-buffer (posn-window (event-start event))) + (let ((buffer completion-reference-buffer) + (base-size completion-base-size) + (base-position completion-base-position) + (insert-function completion-list-insert-choice-function) + (choice + (save-excursion + (goto-char (posn-point (event-start event))) + (let (beg end) + (cond + ((and (not (eobp)) (get-text-property (point) 'mouse-face)) + (setq end (point) beg (1+ (point)))) + ((and (not (bobp)) + (get-text-property (1- (point)) 'mouse-face)) + (setq end (1- (point)) beg (point))) + (t (error "No completion here"))) + (setq beg (previous-single-property-change beg 'mouse-face)) + (setq end (or (next-single-property-change end 'mouse-face) + (point-max))) + (buffer-substring-no-properties beg end)))) + (owindow (selected-window))) + + (unless (buffer-live-p buffer) + (error "Destination buffer is dead")) (select-window (posn-window (event-start event))) (if (and (one-window-p t 'selected-frame) (window-dedicated-p (selected-window))) @@ -6014,20 +6022,20 @@ With prefix argument N, move N items (negative N means move backward)." (or (window-dedicated-p (selected-window)) (bury-buffer))) (select-window - (or (and (buffer-live-p buffer) - (get-buffer-window buffer 0)) - owindow))) - - (choose-completion-string - choice buffer - (or base-position - (when base-size - ;; Someone's using old completion code that doesn't know - ;; about base-position yet. - (list (+ base-size (with-current-buffer buffer (field-beginning))))) - ;; If all else fails, just guess. - (with-current-buffer buffer - (list (choose-completion-guess-base-position choice))))))) + (or (get-buffer-window buffer 0) + owindow)) + + (with-current-buffer buffer + (choose-completion-string + choice buffer + (or base-position + (when base-size + ;; Someone's using old completion code that doesn't know + ;; about base-position yet. + (list (+ base-size (field-beginning)))) + ;; If all else fails, just guess. + (list (choose-completion-guess-base-position choice))) + insert-function))))) ;; Delete the longest partial match for STRING ;; that can be found before POINT. @@ -6073,7 +6081,8 @@ 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.") -(defun choose-completion-string (choice &optional buffer base-position) +(defun choose-completion-string (choice &optional + buffer base-position insert-function) "Switch to BUFFER and insert the completion choice CHOICE. BASE-POSITION, says where to insert the completion." @@ -6093,8 +6102,8 @@ BASE-POSITION, says where to insert the completion." ;; If BUFFER is a minibuffer, barf unless it's the currently ;; active minibuffer. (if (and mini-p - (or (not (active-minibuffer-window)) - (not (equal buffer + (not (and (active-minibuffer-window) + (equal buffer (window-buffer (active-minibuffer-window)))))) (error "Minibuffer is not active for completion") ;; Set buffer so buffer-local choose-completion-string-functions works. @@ -6106,13 +6115,15 @@ BASE-POSITION, says where to insert the completion." ;; and indeed unused. The last used to be `base-size', so we ;; keep it to try and avoid breaking old code. choice buffer base-position nil) + ;; This remove-text-properties should be unnecessary since `choice' + ;; comes from buffer-substring-no-properties. + ;;(remove-text-properties 0 (lenth choice) '(mouse-face nil) choice) ;; Insert the completion into the buffer where it was requested. - (delete-region (or (car base-position) (point)) - (or (cadr base-position) (point))) - (insert choice) - (remove-text-properties (- (point) (length choice)) (point) - '(mouse-face nil)) - ;; Update point in the window that BUFFER is showing in. + (funcall (or insert-function completion-list-insert-choice-function) + (or (car base-position) (point)) + (or (cadr base-position) (point)) + choice) + ;; 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. @@ -6178,10 +6189,13 @@ Called from `temp-buffer-show-hook'." 0 (or completion-base-size 0))))))) (with-current-buffer standard-output (let ((base-size completion-base-size) ;Read before killing localvars. - (base-position completion-base-position)) + (base-position completion-base-position) + (insert-fun completion-list-insert-choice-function)) (completion-list-mode) (set (make-local-variable 'completion-base-size) base-size) - (set (make-local-variable 'completion-base-position) base-position)) + (set (make-local-variable 'completion-base-position) base-position) + (set (make-local-variable 'completion-list-insert-choice-function) + insert-fun)) (set (make-local-variable 'completion-reference-buffer) mainbuf) (if base-dir (setq default-directory base-dir)) ;; Maybe insert help string. @@ -6218,27 +6232,27 @@ select the completion near point.\n\n")))))) ;; These functions -- which are not commands -- each add one modifier ;; to the following event. -(defun event-apply-alt-modifier (ignore-prompt) +(defun event-apply-alt-modifier (_ignore-prompt) "\\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) +(defun event-apply-super-modifier (_ignore-prompt) "\\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) +(defun event-apply-hyper-modifier (_ignore-prompt) "\\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) +(defun event-apply-shift-modifier (_ignore-prompt) "\\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) +(defun event-apply-control-modifier (_ignore-prompt) "\\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) +(defun event-apply-meta-modifier (_ignore-prompt) "\\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-"))) @@ -6589,11 +6603,10 @@ See also `normal-erase-is-backspace'." (cond ((or (memq window-system '(x w32 ns pc)) (memq system-type '(ms-dos windows-nt))) - (let* ((bindings - `(([M-delete] [M-backspace]) - ([C-M-delete] [C-M-backspace]) - ([?\e C-delete] [?\e C-backspace]))) - (old-state (lookup-key local-function-key-map [delete]))) + (let ((bindings + `(([M-delete] [M-backspace]) + ([C-M-delete] [C-M-backspace]) + ([?\e C-delete] [?\e C-backspace])))) (if enabled (progn @@ -6647,37 +6660,25 @@ saving the value of `buffer-invisibility-spec' and setting it to nil." buffer-invisibility-spec) (setq buffer-invisibility-spec nil))) -;; Partial application of functions (similar to "currying"). -;; This function is here rather than in subr.el because it uses CL. -(defun apply-partially (fun &rest args) - "Return a function that is a partial application of FUN to ARGS. -ARGS is a list of the first N arguments to pass to FUN. -The result is a new function which does the same as FUN, except that -the first N arguments are fixed at the values with which this function -was called." - (lexical-let ((fun fun) (args1 args)) - (lambda (&rest args2) (apply fun (append args1 args2))))) - ;; Minibuffer prompt stuff. -;(defun minibuffer-prompt-modification (start end) -; (error "You cannot modify the prompt")) -; -; -;(defun minibuffer-prompt-insertion (start end) -; (let ((inhibit-modification-hooks t)) -; (delete-region start end) -; ;; Discard undo information for the text insertion itself -; ;; and for the text deletion.above. -; (when (consp buffer-undo-list) -; (setq buffer-undo-list (cddr buffer-undo-list))) -; (message "You cannot modify the prompt"))) -; -; -;(setq minibuffer-prompt-properties -; (list 'modification-hooks '(minibuffer-prompt-modification) -; 'insert-in-front-hooks '(minibuffer-prompt-insertion))) -; +;;(defun minibuffer-prompt-modification (start end) +;; (error "You cannot modify the prompt")) +;; +;; +;;(defun minibuffer-prompt-insertion (start end) +;; (let ((inhibit-modification-hooks t)) +;; (delete-region start end) +;; ;; Discard undo information for the text insertion itself +;; ;; and for the text deletion.above. +;; (when (consp buffer-undo-list) +;; (setq buffer-undo-list (cddr buffer-undo-list))) +;; (message "You cannot modify the prompt"))) +;; +;; +;;(setq minibuffer-prompt-properties +;; (list 'modification-hooks '(minibuffer-prompt-modification) +;; 'insert-in-front-hooks '(minibuffer-prompt-insertion))) ;;;; Problematic external packages.