diff options
Diffstat (limited to 'lisp/simple.el')
| -rw-r--r-- | lisp/simple.el | 797 |
1 files changed, 647 insertions, 150 deletions
diff --git a/lisp/simple.el b/lisp/simple.el index d91efb23363..0645f18cc78 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -623,7 +623,7 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'." (beforepos (point)) (last-command-event ?\n) ;; Don't auto-fill if we have a prefix argument. - (auto-fill-function (if arg nil auto-fill-function)) + (inhibit-auto-fill (or inhibit-auto-fill arg)) (arg (prefix-numeric-value arg)) (procsym (make-symbol "newline-postproc")) ;(bug#46326) (postproc @@ -1029,7 +1029,7 @@ that if you use overwrite mode as your normal editing mode, you can use this function to insert characters when necessary. In binary overwrite mode, this function does overwrite, and octal -(or decimal or hex) digits are interpreted as a character code. This +\(or decimal or hex) digits are interpreted as a character code. This is intended to be useful for editing binary files." (interactive "*p") (let* ((char @@ -1762,6 +1762,7 @@ not at the start of a line. When IGNORE-INVISIBLE-LINES is non-nil, invisible lines are not included in the count." + (declare (side-effect-free t)) (save-excursion (save-restriction (narrow-to-region start end) @@ -2086,6 +2087,9 @@ of the prefix argument for `eval-expression' and ((= num -1) most-positive-fixnum) (t eval-expression-print-maximum-character))))) +(defun eval-expression--debug (err) + (funcall debugger 'error err :backtrace-base #'eval-expression--debug)) + ;; We define this, rather than making `eval' interactive, ;; for the sake of completion of names like eval-region, eval-buffer. (defun eval-expression (exp &optional insert-value no-truncate char-print-limit) @@ -2119,23 +2123,17 @@ this command arranges for all errors to enter the debugger." (cons (read--expression "Eval: ") (eval-expression-get-print-arguments current-prefix-arg))) - (let (result) + (let* (result + (runfun + (lambda () + (setq result + (values--store-value + (eval (let ((lexical-binding t)) (macroexpand-all exp)) + t)))))) (if (null eval-expression-debug-on-error) - (setq result - (values--store-value - (eval (let ((lexical-binding t)) (macroexpand-all exp)) t))) - (let ((old-value (make-symbol "t")) new-value) - ;; Bind debug-on-error to something unique so that we can - ;; detect when evalled code changes it. - (let ((debug-on-error old-value)) - (setq result - (values--store-value - (eval (let ((lexical-binding t)) (macroexpand-all exp)) t))) - (setq new-value debug-on-error)) - ;; If evalled code has changed the value of debug-on-error, - ;; propagate that change to the global binding. - (unless (eq old-value new-value) - (setq debug-on-error new-value)))) + (funcall runfun) + (handler-bind ((error #'eval-expression--debug)) + (funcall runfun))) (let ((print-length (unless no-truncate eval-expression-print-length)) (print-level (unless no-truncate eval-expression-print-level)) @@ -2426,9 +2424,7 @@ BUFFER." "Say whether MODES are in action in BUFFER. This is the case if either the major mode is derived from one of MODES, or (if one of MODES is a minor mode), if it is switched on in BUFFER." - (or (apply #'provided-mode-derived-p - (buffer-local-value 'major-mode buffer) - modes) + (or (provided-mode-derived-p (buffer-local-value 'major-mode buffer) modes) ;; It's a minor mode. (seq-intersection modes (buffer-local-value 'local-minor-modes buffer) @@ -2503,7 +2499,7 @@ Equivalent key-bindings are also shown in the completion list of :group 'keyboard :type '(choice (const :tag "off" nil) (natnum :tag "time" 2) - (other :tag "on"))) + (other :tag "on" t))) (defcustom extended-command-suggest-shorter t "If non-nil, show a shorter \\[execute-extended-command] invocation \ @@ -2719,7 +2715,16 @@ function as needed." (let ((doc (car body))) (when (funcall docstring-p doc) doc))) - (_ (signal 'invalid-function (list function)))))) + ((pred symbolp) + (let ((f (indirect-function function))) + (if f (function-documentation f) + (signal 'void-function (list function))))) + (`(macro . ,f) (function-documentation f)) + (_ + (let ((doc (internal-subr-documentation function))) + (if (eq t doc) + (signal 'invalid-function (list function)) + doc)))))) (cl-defmethod function-documentation ((function accessor)) (oclosure--accessor-docstring function)) ;; FIXME: η-reduce! @@ -2739,7 +2744,8 @@ instead." nil) (cl-defmethod oclosure-interactive-form ((f cconv--interactive-helper)) - `(interactive (funcall ',(cconv--interactive-helper--if f)))) + (let ((if (cconv--interactive-helper--if f))) + `(interactive ,(if (functionp if) `(funcall ',if) if)))) (defun command-execute (cmd &optional record-flag keys special) ;; BEWARE: Called directly from the C code. @@ -2978,11 +2984,17 @@ this by calling a function defined by `minibuffer-default-add-function'.") (defun minibuffer-default-add-completions () "Return a list of all completions without the default value. This function is used to add all elements of the completion table to -the end of the list of defaults just after the default value." +the end of the list of defaults just after the default value. +If you don't want to add initial completions to the default value, +use either `minibuffer-setup-hook' or `minibuffer-with-setup-hook' +to set the value of `minibuffer-default-add-function' to nil." (let ((def minibuffer-default) - (all (all-completions "" - minibuffer-completion-table - minibuffer-completion-predicate))) + ;; Avoid some popular completions with undefined order + (all (unless (memq minibuffer-completion-table + `(help--symbol-completion-table ,obarray)) + (all-completions "" + minibuffer-completion-table + minibuffer-completion-predicate)))) (if (listp def) (append def all) (cons def (delete def all))))) @@ -3862,16 +3874,14 @@ whether (MARKER . ADJUSTMENT) undo elements are in the region, because markers can be arbitrarily relocated. Instead, pass the marker adjustment's corresponding (TEXT . POS) element." (cond ((integerp undo-elt) - (and (>= undo-elt start) - (<= undo-elt end))) + (<= start undo-elt end)) ((eq undo-elt nil) t) ((atom undo-elt) nil) ((stringp (car undo-elt)) ;; (TEXT . POSITION) - (and (>= (abs (cdr undo-elt)) start) - (<= (abs (cdr undo-elt)) end))) + (<= start (abs (cdr undo-elt)) end)) ((and (consp undo-elt) (markerp (car undo-elt))) ;; (MARKER . ADJUSTMENT) (<= start (car undo-elt) end)) @@ -4086,10 +4096,11 @@ default values.") "Amalgamate undo if necessary. This function can be called before an amalgamating command. It removes the previous `undo-boundary' if a series of such calls -have been made. By default `self-insert-command' and -`delete-char' are the only amalgamating commands, although this -function could be called by any command wishing to have this -behavior." +have been made. `self-insert-command' and `delete-char' are the +most common amalgamating commands, although this function can be +called by any command which desires this behavior. +`analyze-text-conversion' (which see) is also an amalgamating +command in most circumstances." (let ((last-amalgamating-count (undo-auto--last-boundary-amalgamating-number))) (setq undo-auto--this-command-amalgamating t) @@ -4259,19 +4270,19 @@ This buffer is used when `shell-command' or `shell-command-on-region' is run interactively. A value of nil means that output to stderr and stdout will be intermixed in the output stream.") -(declare-function mailcap-file-default-commands "mailcap" (files)) (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) +(declare-function shell-command-guess "dired-aux" (files)) (defun minibuffer-default-add-shell-commands () "Return a list of all commands associated with the current file. -This function is used to add all related commands retrieved by `mailcap' -to the end of the list of defaults just after the default value." - (interactive) +This function is used to add all related commands retrieved by +`shell-command-guess' to the end of the list of defaults just +after the default value." (let* ((filename (if (listp minibuffer-default) (car minibuffer-default) minibuffer-default)) - (commands (and filename (require 'mailcap nil t) - (mailcap-file-default-commands (list filename))))) + (commands (and filename (require 'dired-aux) + (shell-command-guess (list filename))))) (setq commands (mapcar (lambda (command) (concat command " " filename)) commands)) @@ -4725,7 +4736,7 @@ impose the use of a shell (with its need to quote arguments)." (when (buffer-live-p buf) (remove-function (process-filter proc) nonce) - (display-buffer buf)))) + (display-buffer buf '(nil (allow-no-window . t)))))) `((name . ,nonce))))))) ;; Otherwise, command is executed synchronously. (shell-command-on-region (point) (point) command @@ -4749,6 +4760,30 @@ Also see the `async-shell-command-buffer' variable." action)) (user-error "Shell command in progress")))) +(defun file-user-uid () + "Return the connection-local effective uid. +This is similar to `user-uid', but may invoke a file name handler +based on `default-directory'. See Info node `(elisp)Magic File +Names'. + +If a file name handler is unable to retrieve the effective uid, +this function will instead return -1." + (if-let ((handler (find-file-name-handler default-directory 'file-user-uid))) + (funcall handler 'file-user-uid) + (user-uid))) + +(defun file-group-gid () + "Return the connection-local effective gid. +This is similar to `group-gid', but may invoke a file name handler +based on `default-directory'. See Info node `(elisp)Magic File +Names'. + +If a file name handler is unable to retrieve the effective gid, +this function will instead return -1." + (if-let ((handler (find-file-name-handler default-directory 'file-group-gid))) + (funcall handler 'file-group-gid) + (group-gid))) + (defun max-mini-window-lines (&optional frame) "Compute maximum number of lines for echo area in FRAME. As defined by `max-mini-window-height'. FRAME defaults to the @@ -4865,7 +4900,7 @@ appears at the end of the output. Optional fourth arg OUTPUT-BUFFER specifies where to put the command's output. If the value is a buffer or buffer name, erase that buffer and insert the output there; a non-nil value of -`shell-command-dont-erase-buffer' prevent to erase the buffer. +`shell-command-dont-erase-buffer' prevents erasing the buffer. If the value is nil, use the buffer specified by `shell-command-buffer-name'. Any other non-nil value means to insert the output in the current buffer after START. @@ -5121,7 +5156,7 @@ never with `setq'.") (defcustom process-file-return-signal-string nil "Whether to return a string describing the signal interrupting a process. When a process returns an exit code greater than 128, it is -interpreted as a signal. `process-file' requires to return a +interpreted as a signal. `process-file' requires returning a string describing this signal. Since there are processes violating this rule, returning exit codes greater than 128 which are not bound to a signal, @@ -6384,7 +6419,7 @@ PROMPT is a string to prompt with." 0 (length s) '( keymap local-map action mouse-action - button category help-args) + read-only button category help-args) s) s) kill-ring)) @@ -6435,9 +6470,9 @@ If non-nil, the kill ring is rotated after selecting previously killed text." (defun yank-from-kill-ring (string &optional arg) "Select a stretch of previously killed text and insert (\"paste\") it. -This command allows to choose one of the stretches of text killed -or yanked by previous commands, which are recorded in `kill-ring', -and reinsert the chosen kill at point. +This command allows you to select one of the stretches of text +killed or yanked by previous commands, which are recorded in +`kill-ring', and reinsert the chosen kill at point. This command prompts for a previously-killed text in the minibuffer. Use the minibuffer history and search commands, or the minibuffer @@ -6538,7 +6573,7 @@ If the Unicode tables are not yet available, e.g. during bootstrap, then gives correct answers only for ASCII characters." (cond ((unicode-property-table-internal 'lowercase) (characterp (get-char-code-property char 'lowercase))) - ((and (>= char ?A) (<= char ?Z))))) + ((<= ?A char ?Z)))) (defun zap-to-char (arg char &optional interactive) "Kill up to and including ARGth occurrence of CHAR. @@ -6848,6 +6883,7 @@ is active, and returns an integer or nil in the usual way. If you are using this in an editing command, you are most likely making a mistake; see the documentation of `set-mark'." + (declare (side-effect-free t)) (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive) (marker-position (mark-marker)) (signal 'mark-inactive nil))) @@ -8418,7 +8454,7 @@ even beep.)" (and (= (cdr (nth 6 (posn-at-point))) orig-vlnum) ;; Make sure we delete the character where the line wraps ;; under visual-line-mode, be it whitespace or a - ;; character whose category set allows to wrap at it. + ;; character whose category set permits wrapping at it. (or (looking-at-p "[ \t]") (and word-wrap-by-category (aref (char-category-set (following-char)) ?\|))) @@ -8544,12 +8580,12 @@ variables `truncate-lines' and `truncate-partial-width-windows'." "Interchange characters around point, moving forward one character. With prefix arg ARG, effect is to take character before point and drag it forward past ARG other characters (backward if ARG negative). -If no argument and at end of line, the previous two chars are exchanged." - (interactive "*P") - (when (and (null arg) (eolp) (not (bobp)) +If at end of line, the previous two chars are exchanged." + (interactive "*p") + (when (and (eolp) (not (bobp)) (not (get-text-property (1- (point)) 'read-only))) (forward-char -1)) - (transpose-subr 'forward-char (prefix-numeric-value arg))) + (transpose-subr #'forward-char arg)) (defun transpose-words (arg) "Interchange words around point, leaving point at end of them. @@ -8561,6 +8597,45 @@ are interchanged." (interactive "*p") (transpose-subr 'forward-word arg)) +(defun transpose-sexps-default-function (arg) + "Default method to locate a pair of points for transpose-sexps." + ;; Here we should try to simulate the behavior of + ;; (cons (progn (forward-sexp x) (point)) + ;; (progn (forward-sexp (- x)) (point))) + ;; Except that we don't want to rely on the second forward-sexp + ;; putting us back to where we want to be, since forward-sexp-function + ;; might do funny things like infix-precedence. + (if (if (> arg 0) + (looking-at "\\sw\\|\\s_") + (and (not (bobp)) + (save-excursion + (forward-char -1) + (looking-at "\\sw\\|\\s_")))) + ;; Jumping over a symbol. We might be inside it, mind you. + (progn (funcall (if (> arg 0) + #'skip-syntax-backward #'skip-syntax-forward) + "w_") + (cons (save-excursion (forward-sexp arg) (point)) (point))) + ;; Otherwise, we're between sexps. Take a step back before jumping + ;; to make sure we'll obey the same precedence no matter which + ;; direction we're going. + (funcall (if (> arg 0) #'skip-syntax-backward #'skip-syntax-forward) + " .") + (cons (save-excursion (forward-sexp arg) (point)) + (progn (while (or (forward-comment (if (> arg 0) 1 -1)) + (not (zerop (funcall (if (> arg 0) + #'skip-syntax-forward + #'skip-syntax-backward) + "."))))) + (point))))) + +(defvar transpose-sexps-function #'transpose-sexps-default-function + "If non-nil, `transpose-sexps' delegates to this function. + +This function takes one argument ARG, a number. Its expected +return value is a position pair, which is a cons (BEG . END), +where BEG and END are buffer positions.") + (defun transpose-sexps (arg &optional interactive) "Like \\[transpose-chars] (`transpose-chars'), but applies to sexps. Unlike `transpose-words', point must be between the two sexps and not @@ -8576,38 +8651,7 @@ report errors as appropriate for this kind of usage." (condition-case nil (transpose-sexps arg nil) (scan-error (user-error "Not between two complete sexps"))) - (transpose-subr - (lambda (arg) - ;; Here we should try to simulate the behavior of - ;; (cons (progn (forward-sexp x) (point)) - ;; (progn (forward-sexp (- x)) (point))) - ;; Except that we don't want to rely on the second forward-sexp - ;; putting us back to where we want to be, since forward-sexp-function - ;; might do funny things like infix-precedence. - (if (if (> arg 0) - (looking-at "\\sw\\|\\s_") - (and (not (bobp)) - (save-excursion - (forward-char -1) - (looking-at "\\sw\\|\\s_")))) - ;; Jumping over a symbol. We might be inside it, mind you. - (progn (funcall (if (> arg 0) - 'skip-syntax-backward 'skip-syntax-forward) - "w_") - (cons (save-excursion (forward-sexp arg) (point)) (point))) - ;; Otherwise, we're between sexps. Take a step back before jumping - ;; to make sure we'll obey the same precedence no matter which - ;; direction we're going. - (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) - " .") - (cons (save-excursion (forward-sexp arg) (point)) - (progn (while (or (forward-comment (if (> arg 0) 1 -1)) - (not (zerop (funcall (if (> arg 0) - 'skip-syntax-forward - 'skip-syntax-backward) - "."))))) - (point))))) - arg 'special))) + (transpose-subr transpose-sexps-function arg 'special))) (defun transpose-lines (arg) "Exchange current line and previous line, leaving point after both. @@ -8632,13 +8676,15 @@ With argument 0, interchanges line point is in with line mark is in." ;; FIXME document SPECIAL. (defun transpose-subr (mover arg &optional special) "Subroutine to do the work of transposing objects. -Works for lines, sentences, paragraphs, etc. MOVER is a function that -moves forward by units of the given object (e.g. `forward-sentence', -`forward-paragraph'). If ARG is zero, exchanges the current object -with the one containing mark. If ARG is an integer, moves the -current object past ARG following (if ARG is positive) or -preceding (if ARG is negative) objects, leaving point after the -current object." +Works for lines, sentences, paragraphs, etc. MOVER is a function +that moves forward by units of the given +object (e.g. `forward-sentence', `forward-paragraph'), or a +function calculating a cons of buffer positions. + + If ARG is zero, exchanges the current object with the one +containing mark. If ARG is an integer, moves the current object +past ARG following (if ARG is positive) or preceding (if ARG is +negative) objects, leaving point after the current object." (let ((aux (if special mover (lambda (x) (cons (progn (funcall mover x) (point)) @@ -8665,6 +8711,8 @@ current object." (goto-char (+ (car pos2) (- (cdr pos1) (car pos1)))))))) (defun transpose-subr-1 (pos1 pos2) + (unless (and pos1 pos2) + (error "Don't have two things to transpose")) (when (> (car pos1) (cdr pos1)) (setq pos1 (cons (cdr pos1) (car pos1)))) (when (> (car pos2) (cdr pos2)) (setq pos2 (cons (cdr pos2) (car pos2)))) (when (> (car pos1) (car pos2)) @@ -8931,11 +8979,15 @@ unless optional argument SOFT is non-nil." ;; If we're not inside a comment, just try to indent. (t (indent-according-to-mode)))))) +(defvar inhibit-auto-fill nil + "Non-nil means to do as if `auto-fill-mode' was disabled.") + (defun internal-auto-fill () "The function called by `self-insert-command' to perform auto-filling." - (when (or (not comment-start) - (not comment-auto-fill-only-comments) - (nth 4 (syntax-ppss))) + (unless (or inhibit-auto-fill + (and comment-start + comment-auto-fill-only-comments + (not (nth 4 (syntax-ppss))))) (funcall auto-fill-function))) (defvar normal-auto-fill-function 'do-auto-fill @@ -9120,6 +9172,14 @@ presented." "Toggle buffer size display in the mode line (Size Indication mode)." :global t :group 'mode-line) +(defcustom remote-file-name-inhibit-auto-save nil + "When nil, `auto-save-mode' will auto-save remote files. +Any other value means that it will not." + :group 'auto-save + :group 'tramp + :type 'boolean + :version "30.1") + (define-minor-mode auto-save-mode "Toggle auto-saving in the current buffer (Auto Save mode). @@ -9142,6 +9202,9 @@ For more details, see Info node `(emacs) Auto Save'." (setq buffer-auto-save-file-name (cond ((null val) nil) + ((and buffer-file-name remote-file-name-inhibit-auto-save + (file-remote-p buffer-file-name)) + nil) ((and buffer-file-name auto-save-visited-file-name (not buffer-read-only)) buffer-file-name) @@ -9213,6 +9276,21 @@ it skips the contents of comments that end before point." :type 'boolean :group 'paren-blinking) +(defcustom blink-matching-paren-highlight-offscreen nil + "If non-nil, highlight matched off-screen open paren in the echo area. +This highlighting uses the `blink-matching-paren-offscreen' face." + :type 'boolean + :version "30.1" + :group 'paren-blinking) + +(defface blink-matching-paren-offscreen + '((t :foreground "green")) + "Face for showing in the echo area matched open paren that is off-screen. +This face is used only when `blink-matching-paren-highlight-offscreen' +is non-nil." + :version "30.1" + :group 'paren-blinking) + (defun blink-matching-check-mismatch (start end) "Return whether or not START...END are matching parens. END is the current point and START is the blink position. @@ -9310,47 +9388,78 @@ The function should return non-nil if the two tokens do not match.") (delete-overlay blink-matching--overlay))))) ((not show-paren-context-when-offscreen) (minibuffer-message - "Matches %s" - (substring-no-properties - (blink-paren-open-paren-line-string blinkpos)))))))) + "%s%s" + (propertize "Matches " 'face 'shadow) + (blink-paren-open-paren-line-string blinkpos))))))) (defun blink-paren-open-paren-line-string (pos) - "Return the line string that contains the openparen at POS." + "Return the line string that contains the openparen at POS. +Remove the line string's properties but give the openparen a distinct +face if `blink-matching-paren-highlight-offscreen' is non-nil." (save-excursion (goto-char pos) ;; Capture the regions in terms of (beg . end) conses whose ;; buffer-substrings we want to show as a context string. Ensure ;; they are font-locked (bug#59527). - (let (regions) - ;; Show what precedes the open in its line, if anything. + (let (regions + openparen-idx) (cond + ;; Show what precedes the open in its line, if anything. ((save-excursion (skip-chars-backward " \t") (not (bolp))) - (setq regions (list (cons (line-beginning-position) - (1+ pos))))) + (let ((bol (line-beginning-position))) + (setq regions (list (cons bol (1+ pos))) + openparen-idx (- pos bol)))) ;; Show what follows the open in its line, if anything. ((save-excursion (forward-char 1) (skip-chars-forward " \t") (not (eolp))) - (setq regions (list (cons pos (line-end-position))))) + (setq regions (list (cons pos (line-end-position))) + openparen-idx 0)) ;; Otherwise show the previous nonblank line, ;; if there is one. ((save-excursion (skip-chars-backward "\n \t") (not (bobp))) - (setq regions (list (cons (progn - (skip-chars-backward "\n \t") - (line-beginning-position)) - (progn (end-of-line) - (skip-chars-backward " \t") - (point))) + (setq regions (list (cons + (let (bol) + (skip-chars-backward "\n \t") + (setq bol (line-beginning-position) + openparen-idx (- bol)) + bol) + (let (eol) + (end-of-line) + (skip-chars-backward " \t") + (setq eol (point) + openparen-idx (+ openparen-idx + eol + ;; (length "...") + 3)) + eol)) (cons pos (1+ pos))))) ;; There is nothing to show except the char itself. - (t (setq regions (list (cons pos (1+ pos)))))) + (t (setq regions (list (cons pos (1+ pos))) + openparen-idx 0))) ;; Ensure we've font-locked the context region. (font-lock-ensure (caar regions) (cdar (last regions))) - (mapconcat (lambda (region) - (buffer-substring (car region) (cdr region))) - regions - "...")))) + (let ((line-string + (mapconcat + (lambda (region) + (buffer-substring (car region) (cdr region))) + regions + "...")) + (openparen-next-char-idx (1+ openparen-idx))) + (setq line-string (substring-no-properties line-string)) + (concat + (substring line-string + 0 openparen-idx) + (let ((matched-offscreen-openparen + (substring line-string + openparen-idx openparen-next-char-idx))) + (if blink-matching-paren-highlight-offscreen + (propertize matched-offscreen-openparen + 'face 'blink-matching-paren-offscreen) + matched-offscreen-openparen)) + (substring line-string + openparen-next-char-idx)))))) (defvar blink-paren-function 'blink-matching-open "Function called, if non-nil, whenever a close parenthesis is inserted. @@ -9712,10 +9821,15 @@ makes it easier to edit it." (define-key map "\C-m" 'choose-completion) (define-key map "\e\e\e" 'delete-completion-window) (define-key map [remap keyboard-quit] #'delete-completion-window) + (define-key map [up] 'previous-line-completion) + (define-key map [down] 'next-line-completion) (define-key map [left] 'previous-completion) (define-key map [right] 'next-completion) (define-key map [?\t] 'next-completion) (define-key map [backtab] 'previous-completion) + (define-key map [M-up] 'minibuffer-previous-completion) + (define-key map [M-down] 'minibuffer-next-completion) + (define-key map "\M-\r" 'minibuffer-choose-completion) (define-key map "z" 'kill-current-buffer) (define-key map "n" 'next-completion) (define-key map "p" 'previous-completion) @@ -9770,8 +9884,9 @@ Go to the window from which completion was requested." (select-window (get-buffer-window buf)))))) (defcustom completion-auto-wrap t - "Non-nil means to wrap around when selecting completion options. -This affects the commands `next-completion' and `previous-completion'. + "Non-nil means to wrap around when selecting completion candidates. +This affects the commands `next-completion', `previous-completion', +`next-line-completion' and `previous-line-completion'. When `completion-auto-select' is t, it wraps through the minibuffer for the commands bound to the TAB key." :type 'boolean @@ -9779,12 +9894,12 @@ for the commands bound to the TAB key." :group 'completion) (defcustom completion-auto-select nil - "Non-nil means to automatically select the *Completions* buffer. + "If non-nil, automatically select the window showing the *Completions* buffer. When the value is t, pressing TAB will switch to the completion list buffer when Emacs pops up a window showing that buffer. If the value is `second-tab', then the first TAB will pop up the window showing the completions list buffer, and the next TAB will -switch to that window. +select that window. See `completion-auto-help' for controlling when the window showing the completions is popped up and down." :type '(choice (const :tag "Don't auto-select completions window" nil) @@ -9795,7 +9910,7 @@ the completions is popped up and down." :group 'completion) (defun first-completion () - "Move to the first item in the completion list." + "Move to the first item in the completions buffer." (interactive) (goto-char (point-min)) (if (get-text-property (point) 'mouse-face) @@ -9807,7 +9922,7 @@ the completions is popped up and down." (goto-char pos)))) (defun last-completion () - "Move to the last item in the completion list." + "Move to the last item in the completions buffer." (interactive) (goto-char (previous-single-property-change (point-max) 'mouse-face nil (point-min))) @@ -9817,7 +9932,7 @@ the completions is popped up and down." (goto-char pos)))) (defun previous-completion (n) - "Move to the previous item in the completion list. + "Move to the previous item in the completions buffer. With prefix argument N, move back N items (negative N means move forward). @@ -9825,8 +9940,22 @@ Also see the `completion-auto-wrap' variable." (interactive "p") (next-completion (- n))) +(defun completion--move-to-candidate-start () + "If in a completion candidate, move point to its start." + (when (and (get-text-property (point) 'mouse-face) + (not (bobp)) + (get-text-property (1- (point)) 'mouse-face)) + (goto-char (previous-single-property-change (point) 'mouse-face)))) + +(defun completion--move-to-candidate-end () + "If in a completion candidate, move point to its end." + (when (and (get-text-property (point) 'mouse-face) + (not (eobp)) + (get-text-property (1+ (point)) 'mouse-face)) + (goto-char (or (next-single-property-change (point) 'mouse-face) (point-max))))) + (defun next-completion (n) - "Move to the next item in the completion list. + "Move to the next item in the completions buffer. With prefix argument N, move N items (negative N means move backward). @@ -9889,6 +10018,98 @@ Also see the `completion-auto-wrap' variable." (when (/= 0 n) (switch-to-minibuffer)))) +(defun previous-line-completion (&optional n) + "Move to completion candidate on the previous line in the completions buffer. +With prefix argument N, move back N lines (negative N means move forward). + +Also see the `completion-auto-wrap' variable." + (interactive "p") + (next-line-completion (- n))) + +(defun next-line-completion (&optional n) + "Move to completion candidate on the next line in the completions buffer. +With prefix argument N, move N lines forward (negative N means move backward). + +Also see the `completion-auto-wrap' variable." + (interactive "p") + (let (line column pos found) + (when (and (bobp) + (> n 0) + (get-text-property (point) 'mouse-face) + (not (get-text-property (point) 'first-completion))) + (let ((inhibit-read-only t)) + (add-text-properties (point) (1+ (point)) '(first-completion t))) + (setq n (1- n))) + + (if (get-text-property (point) 'mouse-face) + ;; If in a completion, move to the start of it. + (completion--move-to-candidate-start) + ;; Try to move to the previous completion. + (setq pos (previous-single-property-change (point) 'mouse-face)) + (if pos + ;; Move to the start of the previous completion. + (progn + (goto-char pos) + (unless (get-text-property (point) 'mouse-face) + (goto-char (previous-single-property-change + (point) 'mouse-face nil (point-min))))) + (cond ((> n 0) (setq n (1- n)) (first-completion)) + ((< n 0) (first-completion))))) + + (while (> n 0) + (setq found nil pos nil column (current-column) line (line-number-at-pos)) + (completion--move-to-candidate-end) + (while (and (not found) + (eq (forward-line 1) 0) + (not (eobp)) + (move-to-column column)) + (when (get-text-property (point) 'mouse-face) + (setq found t))) + (when (not found) + (if (not completion-auto-wrap) + (last-completion) + (save-excursion + (goto-char (point-min)) + (when (and (eq (move-to-column column) column) + (get-text-property (point) 'mouse-face)) + (setq pos (point))) + (while (and (not pos) (> line (line-number-at-pos))) + (forward-line 1) + (when (and (eq (move-to-column column) column) + (get-text-property (point) 'mouse-face)) + (setq pos (point))))) + (if pos (goto-char pos)))) + (setq n (1- n))) + + (while (< n 0) + (setq found nil pos nil column (current-column) line (line-number-at-pos)) + (completion--move-to-candidate-start) + (while (and (not found) + (eq (forward-line -1) 0) + (move-to-column column)) + (when (get-text-property (point) 'mouse-face) + (setq found t))) + (when (not found) + (if (not completion-auto-wrap) + (first-completion) + (save-excursion + (goto-char (point-max)) + (when (and (eq (move-to-column column) column) + (get-text-property (point) 'mouse-face)) + (setq pos (point))) + (while (and (not pos) (< line (line-number-at-pos))) + (forward-line -1) + (when (and (eq (move-to-column column) column) + (get-text-property (point) 'mouse-face)) + (setq pos (point))))) + (if pos (goto-char pos)))) + (setq n (1+ n))))) + +(defvar choose-completion-deselect-if-after nil + "If non-nil, don't choose a completion candidate if point is right after it. + +This makes `completions--deselect' effective.") + (defun choose-completion (&optional event no-exit no-quit) "Choose the completion at point. If EVENT, use EVENT's position to determine the starting position. @@ -9909,6 +10130,10 @@ minibuffer, but don't quit the completions window." (insert-function completion-list-insert-choice-function) (completion-no-auto-exit (if no-exit t completion-no-auto-exit)) (choice + (if choose-completion-deselect-if-after + (if-let ((str (get-text-property (posn-point (event-start event)) 'completion--string))) + (substring-no-properties str) + (error "No completion here")) (save-excursion (goto-char (posn-point (event-start event))) (let (beg) @@ -9924,7 +10149,7 @@ minibuffer, but don't quit the completions window." beg 'completion--string) beg)) (substring-no-properties - (get-text-property beg 'completion--string)))))) + (get-text-property beg 'completion--string))))))) (unless (buffer-live-p buffer) (error "Destination buffer is dead")) @@ -10073,6 +10298,8 @@ Called from `temp-buffer-show-hook'." :version "22.1" :group 'completion) +(defvar minibuffer-visible-completions--always-bind) + ;; This function goes in completion-setup-hook, so that it is called ;; after the text of the completion list buffer is written. (defun completion-setup-function () @@ -10110,11 +10337,28 @@ Called from `temp-buffer-show-hook'." ;; Maybe insert help string. (when completion-show-help (goto-char (point-min)) - (if (display-mouse-p) - (insert "Click on a completion to select it.\n")) - (insert (substitute-command-keys - "In this buffer, type \\[choose-completion] to \ -select the completion near point.\n\n")))))) + (if minibuffer-visible-completions + (let ((helps + (with-current-buffer (window-buffer (active-minibuffer-window)) + (let ((minibuffer-visible-completions--always-bind t)) + (list + (substitute-command-keys + (if (display-mouse-p) + "Click or type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n" + "Type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n")) + (substitute-command-keys + "Type \\[minibuffer-next-completion], \\[minibuffer-previous-completion], \ +\\[minibuffer-next-line-completion], \\[minibuffer-previous-line-completion] \ +to move point between completions.\n\n")))))) + (dolist (help helps) + (insert help))) + (insert (substitute-command-keys + (if (display-mouse-p) + "Click or type \\[minibuffer-choose-completion] on a completion to select it.\n" + "Type \\[minibuffer-choose-completion] on a completion to select it.\n"))) + (insert (substitute-command-keys + "Type \\[minibuffer-next-completion] or \\[minibuffer-previous-completion] \ +to move point between completions.\n\n"))))))) (add-hook 'completion-setup-hook #'completion-setup-function) @@ -10182,19 +10426,34 @@ SYMBOL is the name of this modifier, as a symbol. LSHIFTBY is the numeric value of this modifier, in keyboard events. PREFIX is the string that represents this modifier in an event type symbol." (if (numberp event) - (cond ((eq symbol 'control) - (if (<= 64 (upcase event) 95) - (- (upcase event) 64) - (logior (ash 1 lshiftby) event))) - ((eq symbol 'shift) - ;; FIXME: Should we also apply this "upcase" behavior of shift - ;; to non-ascii letters? - (if (and (<= (downcase event) ?z) - (>= (downcase event) ?a)) - (upcase event) - (logior (ash 1 lshiftby) event))) - (t - (logior (ash 1 lshiftby) event))) + ;; Use the base event to determine how the control and shift + ;; modifiers should be applied. + (let* ((base-event (event-basic-type event))) + (cond ((eq symbol 'control) + (if (<= 64 (upcase base-event) 95) + ;; Apply the control modifier... + (logior (- (upcase base-event) 64) + ;; ... and any additional modifiers + ;; specified in the original event... + (logand event (logior ?\M-\0 ?\C-\0 ?\S-\0 + ?\H-\0 ?\s-\0 ?\A-\0)) + ;; ... including any shift modifier that + ;; `event-basic-type' may have removed. + (if (<= ?A event ?Z) ?\S-\0 0)) + (logior (ash 1 lshiftby) event))) + ((eq symbol 'shift) + ;; FIXME: Should we also apply this "upcase" behavior of shift + ;; to non-ascii letters? + (if (<= ?a base-event ?z) + ;; Apply the Shift modifier. + (logior (upcase base-event) + ;; ... and any additional modifiers + ;; specified in the original event. + (logand event (logior ?\M-\0 ?\C-\0 ?\S-\0 + ?\H-\0 ?\s-\0 ?\A-\0))) + (logior (ash 1 lshiftby) event))) + (t + (logior (ash 1 lshiftby) event)))) (if (memq symbol (event-modifiers event)) event (let ((event-type (if (symbolp event) event (car event)))) @@ -10467,7 +10726,7 @@ call `normal-erase-is-backspace-mode' (which see) instead." (if (if (eq normal-erase-is-backspace 'maybe) (and (not noninteractive) (or (memq system-type '(ms-dos windows-nt)) - (memq window-system '(w32 ns pgtk haiku)) + (memq window-system '(w32 ns pgtk haiku android)) (and (eq window-system 'x) (fboundp 'x-backspace-delete-keys-p) (x-backspace-delete-keys-p)) @@ -10543,10 +10802,10 @@ See also `normal-erase-is-backspace'." (t (if enabled (progn - (keyboard-translate ?\C-h ?\C-?) - (keyboard-translate ?\C-? ?\C-d)) - (keyboard-translate ?\C-h ?\C-h) - (keyboard-translate ?\C-? ?\C-?)))) + (key-translate "C-h" "DEL") + (key-translate "DEL" "C-d")) + (key-translate "C-h" "C-h") + (key-translate "DEL" "DEL")))) (if (called-interactively-p 'interactive) (message "Delete key deletes %s" @@ -10602,6 +10861,87 @@ and setting it to nil." (setq-local vis-mode-saved-buffer-invisibility-spec buffer-invisibility-spec) (setq buffer-invisibility-spec nil))) + + +(defvar read-passwd--mode-line-buffer nil + "Buffer to modify `mode-line-format' for showing/hiding passwords.") + +(defvar read-passwd--mode-line-icon nil + "Propertized mode line icon for showing/hiding passwords.") + +(defun read-passwd-toggle-visibility () + "Toggle minibuffer contents visibility. +Adapt also mode line." + (interactive) + (setq read-passwd--hide-password (not read-passwd--hide-password)) + (with-current-buffer read-passwd--mode-line-buffer + (setq read-passwd--mode-line-icon + `(:propertize + ,(if icon-preference + (icon-string + (if read-passwd--hide-password + 'read-passwd--show-password-icon + 'read-passwd--hide-password-icon)) + "") + mouse-face mode-line-highlight + local-map + (keymap + (mode-line keymap (mouse-1 . read-passwd-toggle-visibility))))) + (force-mode-line-update)) + (read-passwd--hide-password)) + +(define-minor-mode read-passwd-mode + "Toggle visibility of password in minibuffer." + :group 'mode-line + :group 'minibuffer + :keymap read-passwd-map + :version "30.1" + + (require 'icons) + ;; It would be preferable to use "👁" ("\N{EYE}"). However, there is + ;; no corresponding Unicode char with a slash. So we use symbols as + ;; fallback only, with "⦵" ("\N{CIRCLE WITH HORIZONTAL BAR}") for + ;; hiding the password. + (define-icon read-passwd--show-password-icon nil + '((image "reveal.svg" "reveal.pbm" :height (0.8 . em)) + (symbol "👁") + (text "<o>")) + "Mode line icon to show a hidden password." + :group mode-line-faces + :version "30.1" + :help-echo "mouse-1: Toggle password visibility") + (define-icon read-passwd--hide-password-icon nil + '((image "conceal.svg" "conceal.pbm" :height (0.8 . em)) + (symbol "⦵") + (text "<\\>")) + "Mode line icon to hide a visible password." + :group mode-line-faces + :version "30.1" + :help-echo "mouse-1: Toggle password visibility") + + (setq read-passwd--hide-password nil + ;; Stolen from `eldoc-minibuffer-message'. + read-passwd--mode-line-buffer + (window-buffer + (or (window-in-direction 'above (minibuffer-window)) + (minibuffer-selected-window) + (get-largest-window)))) + + (if read-passwd-mode + (with-current-buffer read-passwd--mode-line-buffer + ;; Add `read-passwd--mode-line-icon'. + (when (listp mode-line-format) + (setq mode-line-format + (cons '(:eval read-passwd--mode-line-icon) + mode-line-format)))) + (with-current-buffer read-passwd--mode-line-buffer + ;; Remove `read-passwd--mode-line-icon'. + (when (listp mode-line-format) + (setq mode-line-format (cdr mode-line-format))))) + + (when read-passwd-mode + (read-passwd-toggle-visibility))) + (defvar messages-buffer-mode-map (let ((map (make-sparse-keymap))) @@ -10886,6 +11226,7 @@ killed." (defsubst string-empty-p (string) "Check whether STRING is empty." + (declare (pure t) (side-effect-free t)) (string= string "")) (defun read-signal-name () @@ -10903,15 +11244,171 @@ killed." (defun lax-plist-get (plist prop) "Extract a value from a property list, comparing with `equal'." - (declare (obsolete plist-get "29.1")) + (declare (pure t) (side-effect-free t) (obsolete plist-get "29.1")) (plist-get plist prop #'equal)) (defun lax-plist-put (plist prop val) "Change value in PLIST of PROP to VAL, comparing with `equal'." (declare (obsolete plist-put "29.1")) (plist-put plist prop val #'equal)) + +;; Text conversion support. See textconv.c for more details about +;; what this is. + +;; Actually in textconv.c. +(defvar text-conversion-edits) + +;; Actually in elec-pair.el. +(defvar electric-pair-preserve-balance) +(declare-function electric-pair-analyze-conversion "elec-pair.el") + +;; Actually in emacs-lisp/timer.el. +(declare-function timer-set-time "emacs-lisp/timer.el") + +(defvar-local post-text-conversion-hook nil + "Hook run after text is inserted by an input method. +Each function in this list is run until one returns non-nil. +When run, `last-command-event' is bound to the last character +that was inserted by the input method.") + +(defun analyze-text-conversion () + "Analyze the results of the previous text conversion event. + +For each insertion: + + - Look for the insertion of a string starting or ending with a + character inside `auto-fill-chars', and fill the text around + it if `auto-fill-mode' is enabled. + + - Look for the insertion of a new line, and cause automatic + line breaking of the previous line when `auto-fill-mode' is + enabled. + + - Look for the deletion of a single electric pair character, + and delete the adjacent pair if + `electric-pair-delete-adjacent-pairs'. + + - Run `post-self-insert-hook' for the last character of + any inserted text so that modes such as `electric-pair-mode' + can work. + + - Run `post-text-conversion-hook' with `last-command-event' set + to the last character of any inserted text to finish up. + +Finally, amalgamate recent changes to the undo list with previous +ones, unless a new line has been inserted or auto-fill has taken +place. If undo information is being recorded, make sure +`undo-auto-current-boundary-timer' will run within the next 5 +seconds." + (interactive) + ;; One important consideration to bear in mind when adjusting this + ;; code is to _never_ move point in reaction to an edit so long as + ;; the additional processing undertaken by this function does not + ;; also edit the buffer text. + (let ((any-nonephemeral nil) + point-moved) + ;; The list must be processed in reverse. + (dolist (edit (reverse text-conversion-edits)) + ;; Filter out ephemeral edits and deletions after point. Here, we + ;; are only interested in insertions or deletions whose contents + ;; can be identified. + (when (stringp (nth 3 edit)) + (with-current-buffer (car edit) + ;; Record that the point hasn't been moved by the execution + ;; of a post command or text conversion hook. + (setq point-moved nil) + (if (not (eq (nth 1 edit) (nth 2 edit))) + ;; Process this insertion. (nth 3 edit) is the text which + ;; was inserted. + (let* ((inserted (nth 3 edit)) + ;; Get the first and last characters. + (start (aref inserted 0)) + (end (aref inserted (1- (length inserted)))) + ;; Figure out whether or not to auto-fill. + (auto-fill-p (or (aref auto-fill-chars start) + (aref auto-fill-chars end))) + ;; Figure out whether or not a newline was inserted. + (newline-p (string-search "\n" inserted)) + ;; Save the current undo list to figure out + ;; whether or not auto-fill has actually taken + ;; place. + (old-undo-list buffer-undo-list) + ;; Save the point position to return it there + ;; later. + (old-point (point))) + (save-excursion + (if (and auto-fill-function newline-p) + (progn (goto-char (nth 2 edit)) + (previous-logical-line) + (funcall auto-fill-function) + (setq old-point (point))) + (when (and auto-fill-function auto-fill-p) + (goto-char (nth 2 edit)) + (funcall auto-fill-function) + (setq old-point (point)))) + ;; Record whether or not this edit should result in + ;; an undo boundary being added. + (setq any-nonephemeral + (or any-nonephemeral newline-p + ;; See if auto-fill has taken place by + ;; comparing the current undo list with + ;; the saved head. + (not (eq old-undo-list + buffer-undo-list))))) + (goto-char (nth 2 edit)) + (let ((last-command-event end) + (point (point))) + (unless (run-hook-with-args-until-success + 'post-text-conversion-hook) + (run-hooks 'post-self-insert-hook)) + (when (not (eq (point) point)) + (setq point-moved t))) + ;; If post-self-insert-hook doesn't move the point, + ;; restore it to its previous location. Generally, + ;; the call to goto-char upon processing the last edit + ;; recorded text-conversion-edit will see to this, but + ;; if the input method sets point expressly, no edit + ;; will be recorded, and point will wind up away from + ;; where the input method believes it is. + (unless point-moved + (goto-char old-point))) + ;; Process this deletion before point. (nth 2 edit) is the + ;; text which was deleted. Input methods typically prefer + ;; to edit words instead of deleting characters off their + ;; ends, but they seem to always send proper requests for + ;; deletion for punctuation. + (when (and (boundp 'electric-pair-delete-adjacent-pairs) + (symbol-value 'electric-pair-delete-adjacent-pairs) + ;; Make sure elec-pair is loaded. + (fboundp 'electric-pair-analyze-conversion) + ;; Only do this if only a single edit happened. + text-conversion-edits) + (save-excursion + (goto-char (nth 2 edit)) + (electric-pair-analyze-conversion (nth 3 edit)))))))) + ;; If all edits were ephemeral, make this an amalgamating command. + ;; Then, make sure that an undo boundary is placed within the next + ;; five seconds. + (unless any-nonephemeral + (undo-auto-amalgamate) + (let ((timer undo-auto-current-boundary-timer)) + (if timer + ;; The timer is already running. See if it's due to expire + ;; within the next five seconds. + (let ((time (list (aref timer 1) (aref timer 2) + (aref timer 3)))) + (unless (<= (time-convert (time-subtract time nil) + 'integer) + 5) + ;; It's not, so make it run in 5 seconds. + (timer-set-time undo-auto-current-boundary-timer + (time-add nil 5)))) + ;; Otherwise, start it for five seconds from now. + (setq undo-auto-current-boundary-timer + (run-at-time 5 nil #'undo-auto--boundary-timer))))))) + (provide 'simple) ;;; simple.el ends here |