diff options
Diffstat (limited to 'lisp/subr.el')
| -rw-r--r-- | lisp/subr.el | 581 |
1 files changed, 519 insertions, 62 deletions
diff --git a/lisp/subr.el b/lisp/subr.el index 59a1af01ba6..5a5842d4287 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -22,6 +22,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Commentary: + ;;; Code: ;; declare-function's args use &rest, not &optional, for compatibility @@ -166,8 +168,8 @@ variables are literal symbols and should not be quoted. The second VALUE is not computed until after the first VARIABLE is set, and so on; each VALUE can use the new value of variables -set earlier in the ‘setq-local’. The return value of the -‘setq-local’ form is the value of the last VALUE. +set earlier in the `setq-local'. The return value of the +`setq-local' form is the value of the last VALUE. \(fn [VARIABLE VALUE]...)" (declare (debug setq)) @@ -191,7 +193,7 @@ set earlier in the ‘setq-local’. The return value of the "Define VAR as a buffer-local variable with default value VAL. Like `defvar' but additionally marks the variable as being automatically buffer-local wherever it is set." - (declare (debug defvar) (doc-string 3)) + (declare (debug defvar) (doc-string 3) (indent 2)) ;; Can't use backquote here, it's too early in the bootstrap. (list 'progn (list 'defvar var val docstring) (list 'make-variable-buffer-local (list 'quote var)))) @@ -486,7 +488,7 @@ was called." "Return VALUE with its bits shifted left by COUNT. If COUNT is negative, shifting is actually to the right. In this case, if VALUE is a negative fixnum treat it as unsigned, -i.e., subtract 2 * most-negative-fixnum from VALUE before shifting it." +i.e., subtract 2 * `most-negative-fixnum' from VALUE before shifting it." (when (and (< value 0) (< count 0)) (when (< value most-negative-fixnum) (signal 'args-out-of-range (list value count))) @@ -694,7 +696,7 @@ If N is omitted or nil, remove the last element." "Destructively remove `equal' duplicates from LIST. Store the result in LIST and return it. LIST must be a proper list. Of several `equal' occurrences of an element in LIST, the first -one is kept." +one is kept. See `seq-uniq' for non-destructive operation." (let ((l (length list))) (if (> l 100) (let ((hash (make-hash-table :test #'equal :size l)) @@ -923,19 +925,191 @@ side-effects, and the argument LIST is not modified." ;;;; Keymap support. +(defun kbd-valid-p (keys) + "Say whether KEYS is a valid `kbd' sequence. +A `kbd' sequence is a string consisting of one and more key +strokes. The key strokes are separated by a space character. + +Each key stroke is either a single character, or the name of an +event, surrounded by angle brackets. In addition, any key stroke +may be preceded by one or more modifier keys. Finally, a limited +number of characters have a special shorthand syntax. + +Here's some example key sequences. + + \"f\" (the key 'f') + \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') + \"C-c o\" (a two key sequence of the keys 'c' with the control modifier + and then the key 'o') + \"H-<left>\" (the key named \"left\" with the hyper modifier) + \"M-RET\" (the \"return\" key with a meta modifier) + \"C-M-<space>\" (the \"space\" key with both the control and meta modifiers) + +These are the characters that have shorthand syntax: +NUL, RET, TAB, LFD, ESC, SPC, DEL. + +Modifiers have to be specified in this order: + + A-C-H-M-S-s + +which is + + Alt-Control-Hyper-Meta-Shift-super" + (declare (pure t) (side-effect-free t)) + (and (stringp keys) + (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) + (save-match-data + (catch 'exit + (let ((prefixes + "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") + (case-fold-search nil)) + (dolist (key (split-string keys " ")) + ;; Every key might have these modifiers, and they should be + ;; in this order. + (when (string-match (concat "\\`" prefixes) key) + (setq key (substring key (match-end 0)))) + (unless (or (and (= (length key) 1) + ;; Don't accept control characters as keys. + (not (< (aref key 0) ?\s)) + ;; Don't accept Meta'd characters as keys. + (or (multibyte-string-p key) + (not (<= 127 (aref key 0) 255)))) + (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) + ;; Don't allow <M-C-down>. + (= (progn + (string-match + (concat "\\`<" prefixes) key) + (match-end 0)) + 1)) + (string-match-p + "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" + key)) + ;; Invalid. + (throw 'exit nil))) + t))))) + (defun kbd (keys) "Convert KEYS to the internal Emacs key representation. KEYS should be a string in the format returned by commands such as `C-h k' (`describe-key'). + This is the same format used for saving keyboard macros (see `edmacro-mode'). +Here's some example key sequences: + + \"f\" + \"C-c C-c\" + \"H-<left>\" + \"M-RET\" + \"C-M-<return>\" + For an approximate inverse of this, see `key-description'." - ;; Don't use a defalias, since the `pure' property is true only for - ;; the calling convention of `kbd'. (declare (pure t) (side-effect-free t)) ;; A pure function is expected to preserve the match data. - (save-match-data (read-kbd-macro keys))) + (save-match-data + (let ((case-fold-search nil) + (len (length keys)) ; We won't alter keys in the loop below. + (pos 0) + (res [])) + (while (and (< pos len) + (string-match "[^ \t\n\f]+" keys pos)) + (let* ((word-beg (match-beginning 0)) + (word-end (match-end 0)) + (word (substring keys word-beg len)) + (times 1) + key) + ;; Try to catch events of the form "<as df>". + (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) + (setq word (match-string 0 word) + pos (+ word-beg (match-end 0))) + (setq word (substring keys word-beg word-end) + pos word-end)) + (when (string-match "\\([0-9]+\\)\\*." word) + (setq times (string-to-number (substring word 0 (match-end 1)))) + (setq word (substring word (1+ (match-end 1))))) + (cond ((string-match "^<<.+>>$" word) + (setq key (vconcat (if (eq (key-binding [?\M-x]) + 'execute-extended-command) + [?\M-x] + (or (car (where-is-internal + 'execute-extended-command)) + [?\M-x])) + (substring word 2 -2) "\r"))) + ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) + (progn + (setq word (concat (match-string 1 word) + (match-string 3 word))) + (not (string-match + "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" + word)))) + (setq key (list (intern word)))) + ((or (equal word "REM") (string-match "^;;" word)) + (setq pos (string-match "$" keys pos))) + (t + (let ((orig-word word) (prefix 0) (bits 0)) + (while (string-match "^[ACHMsS]-." word) + (setq bits (+ bits (cdr (assq (aref word 0) + '((?A . ?\A-\^@) (?C . ?\C-\^@) + (?H . ?\H-\^@) (?M . ?\M-\^@) + (?s . ?\s-\^@) (?S . ?\S-\^@)))))) + (setq prefix (+ prefix 2)) + (setq word (substring word 2))) + (when (string-match "^\\^.$" word) + (setq bits (+ bits ?\C-\^@)) + (setq prefix (1+ prefix)) + (setq word (substring word 1))) + (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") + ("LFD" . "\n") ("TAB" . "\t") + ("ESC" . "\e") ("SPC" . " ") + ("DEL" . "\177"))))) + (when found (setq word (cdr found)))) + (when (string-match "^\\\\[0-7]+$" word) + (let ((n 0)) + (dolist (ch (cdr (string-to-list word))) + (setq n (+ (* n 8) ch -48))) + (setq word (vector n)))) + (cond ((= bits 0) + (setq key word)) + ((and (= bits ?\M-\^@) (stringp word) + (string-match "^-?[0-9]+$" word)) + (setq key (mapcar (lambda (x) (+ x bits)) + (append word nil)))) + ((/= (length word) 1) + (error "%s must prefix a single character, not %s" + (substring orig-word 0 prefix) word)) + ((and (/= (logand bits ?\C-\^@) 0) (stringp word) + ;; We used to accept . and ? here, + ;; but . is simply wrong, + ;; and C-? is not used (we use DEL instead). + (string-match "[@-_a-z]" word)) + (setq key (list (+ bits (- ?\C-\^@) + (logand (aref word 0) 31))))) + (t + (setq key (list (+ bits (aref word 0))))))))) + (when key + (dolist (_ (number-sequence 1 times)) + (setq res (vconcat res key)))))) + (when (and (>= (length res) 4) + (eq (aref res 0) ?\C-x) + (eq (aref res 1) ?\() + (eq (aref res (- (length res) 2)) ?\C-x) + (eq (aref res (- (length res) 1)) ?\))) + (setq res (apply #'vector (let ((lres (append res nil))) + ;; Remove the first and last two elements. + (setq lres (cdr (cdr lres))) + (nreverse lres) + (setq lres (cdr (cdr lres))) + (nreverse lres) + lres)))) + (if (not (memq nil (mapcar (lambda (ch) + (and (numberp ch) + (<= 0 ch 127))) + res))) + ;; Return a string. + (concat (mapcar #'identity res)) + ;; Return a vector. + res)))) (defun undefined () "Beep to tell the user this binding is undefined." @@ -998,6 +1172,7 @@ Bindings are always added before any inherited map. The order of bindings in a keymap matters only when it is used as a menu, so this function is not useful for non-menu keymaps." + (declare (indent defun)) (unless after (setq after t)) (or (keymapp keymap) (signal 'wrong-type-argument (list 'keymapp keymap))) @@ -1510,8 +1685,10 @@ nil or (STRING . POSITION)'. For more information, see Info node `(elisp)Click Events'." (if (consp event) (nth 1 event) - (or (posn-at-point) - (list (selected-window) (point) '(0 . 0) 0)))) + ;; Use `window-point' for the case when the current buffer + ;; is temporarily switched to some other buffer (bug#50256) + (or (posn-at-point (window-point)) + (list (selected-window) (window-point) '(0 . 0) 0)))) (defun event-end (event) "Return the ending position of EVENT. @@ -1519,8 +1696,10 @@ EVENT should be a click, drag, or key press event. See `event-start' for a description of the value returned." (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event) - (or (posn-at-point) - (list (selected-window) (point) '(0 . 0) 0)))) + ;; Use `window-point' for the case when the current buffer + ;; is temporarily switched to some other buffer (bug#50256) + (or (posn-at-point (window-point)) + (list (selected-window) (window-point) '(0 . 0) 0)))) (defsubst event-click-count (event) "Return the multi-click count of EVENT, a click or drag event. @@ -1746,6 +1925,7 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete 'window-redisplay-end-trigger nil "23.1") (make-obsolete 'set-window-redisplay-end-trigger nil "23.1") (make-obsolete-variable 'operating-system-release nil "28.1") +(make-obsolete-variable 'inhibit-changing-match-data 'save-match-data "29.1") (make-obsolete 'run-window-configuration-change-hook nil "27.1") @@ -2001,10 +2181,10 @@ all symbols are bound before any of the VALUEFORMs are evalled." (t `(let* ,(nreverse seqbinds) ,nbody)))))) (defmacro dlet (binders &rest body) - "Like `let*' but using dynamic scoping." + "Like `let' but using dynamic scoping." (declare (indent 1) (debug let)) ;; (defvar FOO) only affects the current scope, but in order for - ;; this not to affect code after the `let*' we need to create a new scope, + ;; this not to affect code after the main `let' we need to create a new scope, ;; which is what the surrounding `let' is for. ;; FIXME: (let () ...) currently doesn't actually create a new scope, ;; which is why we use (let (_) ...). @@ -2012,7 +2192,7 @@ all symbols are bound before any of the VALUEFORMs are evalled." ,@(mapcar (lambda (binder) `(defvar ,(if (consp binder) (car binder) binder))) binders) - (let* ,binders ,@body))) + (let ,binders ,@body))) (defmacro with-wrapper-hook (hook args &rest body) @@ -2872,9 +3052,23 @@ This function is used by the `interactive' code letter `n'." (defvar read-char-choice-use-read-key nil "Prefer `read-key' when reading a character by `read-char-choice'. -Otherwise, use the minibuffer.") +Otherwise, use the minibuffer. + +When using the minibuffer, the user is less constrained, and can +use the normal commands available in the minibuffer, and can, for +instance, switch to another buffer, do things there, and then +switch back again to the minibuffer before entering the +character. This is not possible when using `read-key', but using +`read-key' may be less confusing to some users.") (defun read-char-choice (prompt chars &optional inhibit-keyboard-quit) + "Read and return one of CHARS, prompting for PROMPT. +Any input that is not one of CHARS is ignored. + +By default, the minibuffer is used to read the key +non-modally (see `read-char-from-minibuffer'). If +`read-char-choice-use-read-key' is non-nil, the modal `read-key' +function is used instead (see `read-char-choice-with-read-key')." (if (not read-char-choice-use-read-key) (read-char-from-minibuffer prompt chars) (read-char-choice-with-read-key prompt chars inhibit-keyboard-quit))) @@ -2884,7 +3078,7 @@ Otherwise, use the minibuffer.") Any input that is not one of CHARS is ignored. If optional argument INHIBIT-KEYBOARD-QUIT is non-nil, ignore -keyboard-quit events while waiting for a valid input. +`keyboard-quit' events while waiting for a valid input. If you bind the variable `help-form' to a non-nil value while calling this function, then pressing `help-char' @@ -3015,6 +3209,7 @@ If there is a natural number at point, use it as default." (set-keymap-parent map minibuffer-local-map) (define-key map [remap self-insert-command] #'read-char-from-minibuffer-insert-char) + (define-key map [remap exit-minibuffer] #'read-char-from-minibuffer-insert-other) (define-key map [remap recenter-top-bottom] #'minibuffer-recenter-top-bottom) (define-key map [remap scroll-up-command] #'minibuffer-scroll-up-command) @@ -3132,9 +3327,10 @@ There is no need to explicitly add `help-char' to CHARS; (define-key map [remap scroll-other-window] #'minibuffer-scroll-other-window) (define-key map [remap scroll-other-window-down] #'minibuffer-scroll-other-window-down) - (define-key map [escape] #'abort-recursive-edit) - (dolist (symbol '(quit exit exit-prefix)) + (define-key map [remap exit] #'y-or-n-p-insert-other) + (dolist (symbol '(exit-prefix quit)) (define-key map (vector 'remap symbol) #'abort-recursive-edit)) + (define-key map [escape] #'abort-recursive-edit) ;; FIXME: try catch-all instead of explicit bindings: ;; (define-key map [remap t] #'y-or-n-p-insert-other) @@ -3174,13 +3370,22 @@ Also discard all previous input in the minibuffer." (defvar y-or-n-p-use-read-key nil "Prefer `read-key' when answering a \"y or n\" question by `y-or-n-p'. -Otherwise, use the minibuffer.") +Otherwise, use the minibuffer. + +When using the minibuffer, the user is less constrained, and can +use the normal commands available in the minibuffer, and can, for +instance, switch to another buffer, do things there, and then +switch back again to the minibuffer before entering the +character. This is not possible when using `read-key', but using +`read-key' may be less confusing to some users.") (defun y-or-n-p (prompt) "Ask user a \"y or n\" question. Return t if answer is \"y\" and nil if it is \"n\". -PROMPT is the string to display to ask the question. It should -end in a space; `y-or-n-p' adds \"(y or n) \" to it. + +PROMPT is the string to display to ask the question; `y-or-n-p' +adds \" (y or n) \" to it. It does not need to end in space, but +if it does up to one space will be removed. If you bind the variable `help-form' to a non-nil value while calling this function, then pressing `help-char' @@ -3203,7 +3408,12 @@ responses, perform the requested window recentering or scrolling and ask again. Under a windowing system a dialog box will be used if `last-nonmenu-event' -is nil and `use-dialog-box' is non-nil." +is nil and `use-dialog-box' is non-nil. + +By default, this function uses the minibuffer to read the key. +If `y-or-n-p-use-read-key' is non-nil, `read-key' is used +instead (which means that the user can't change buffers (and the +like) while `y-or-n-p' is running)." (let ((answer 'recenter) (padded (lambda (prompt &optional dialog) (let ((l (length prompt))) @@ -3332,6 +3542,29 @@ user can undo the change normally." (accept-change-group ,handle) (cancel-change-group ,handle)))))) +(defmacro with-undo-amalgamate (&rest body) + "Like `progn' but perform BODY with amalgamated undo barriers. + +This allows multiple operations to be undone in a single step. +When undo is disabled this behaves like `progn'." + (declare (indent 0) (debug t)) + (let ((handle (make-symbol "--change-group-handle--"))) + `(let ((,handle (prepare-change-group)) + ;; Don't truncate any undo data in the middle of this, + ;; otherwise Emacs might truncate part of the resulting + ;; undo step: we want to mimic the behavior we'd get if the + ;; undo-boundaries were never added in the first place. + (undo-outer-limit nil) + (undo-limit most-positive-fixnum) + (undo-strong-limit most-positive-fixnum)) + (unwind-protect + (progn + (activate-change-group ,handle) + ,@body) + (progn + (accept-change-group ,handle) + (undo-amalgamate-change-group ,handle)))))) + (defun prepare-change-group (&optional buffer) "Return a handle for the current buffer's state, for a change group. If you specify BUFFER, make a handle for BUFFER's state instead. @@ -3531,6 +3764,9 @@ If either NAME or VAL are specified, both should be specified." (defvar suspend-resume-hook nil "Normal hook run by `suspend-emacs', after Emacs is continued.") +(defvar after-pdump-load-hook nil + "Normal hook run after loading the .pdmp file.") + (defvar temp-buffer-show-hook nil "Normal hook run by `with-output-to-temp-buffer' after displaying the buffer. When the hook runs, the temporary buffer is current, and the window it @@ -3681,7 +3917,7 @@ See Info node `(elisp)Security Considerations'." "''" ;; Quote everything except POSIX filename characters. ;; This should be safe enough even for really weird shells. - (replace-regexp-in-string + (string-replace "\n" "'\n'" (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument)))) )) @@ -3859,6 +4095,67 @@ Point in BUFFER will be placed after the inserted text." (with-current-buffer buffer (insert-buffer-substring current start end)))) +(defun replace-string-in-region (string replacement &optional start end) + "Replace STRING with REPLACEMENT in the region from START to END. +The number of replaced occurrences are returned, or nil if STRING +doesn't exist in the region. + +If START is nil, use the current point. If END is nil, use `point-max'. + +Comparisons and replacements are done with fixed case." + (if start + (when (< start (point-min)) + (error "Start before start of buffer")) + (setq start (point))) + (if end + (when (> end (point-max)) + (error "End after end of buffer")) + (setq end (point-max))) + (save-excursion + (let ((matches 0) + (case-fold-search nil)) + (goto-char start) + (while (search-forward string end t) + (delete-region (match-beginning 0) (match-end 0)) + (insert replacement) + (setq matches (1+ matches))) + (and (not (zerop matches)) + matches)))) + +(defun replace-regexp-in-region (regexp replacement &optional start end) + "Replace REGEXP with REPLACEMENT in the region from START to END. +The number of replaced occurrences are returned, or nil if REGEXP +doesn't exist in the region. + +If START is nil, use the current point. If END is nil, use `point-max'. + +Comparisons and replacements are done with fixed case. + +REPLACEMENT can use the following special elements: + + `\\&' in NEWTEXT means substitute original matched text. + `\\N' means substitute what matched the Nth `\\(...\\)'. + If Nth parens didn't match, substitute nothing. + `\\\\' means insert one `\\'. + `\\?' is treated literally." + (if start + (when (< start (point-min)) + (error "Start before start of buffer")) + (setq start (point))) + (if end + (when (> end (point-max)) + (error "End after end of buffer")) + (setq end (point-max))) + (save-excursion + (let ((matches 0) + (case-fold-search nil)) + (goto-char start) + (while (re-search-forward regexp end t) + (replace-match replacement t) + (setq matches (1+ matches))) + (and (not (zerop matches)) + matches)))) + (defun yank-handle-font-lock-face-property (face start end) "If `font-lock-defaults' is nil, apply FACE as a `face' property. START and END denote the start and end of the text to act on. @@ -4289,11 +4586,6 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)" ;; that intends to handle the quit signal next time. (eval '(ignore nil))))) -;; Don't throw `throw-on-input' on those events by default. -(setq while-no-input-ignore-events - '(focus-in focus-out help-echo iconify-frame - make-frame-visible selection-request)) - (defmacro while-no-input (&rest body) "Execute BODY only as long as there's no pending input. If input arrives, that ends the execution of BODY, @@ -4532,6 +4824,20 @@ MODES is as for `set-default-file-modes'." ,@body) (set-default-file-modes ,umask))))) +(defmacro with-existing-directory (&rest body) + "Execute BODY with `default-directory' bound to an existing directory. +If `default-directory' is already an existing directory, it's not changed." + (declare (indent 0) (debug t)) + `(let ((default-directory (seq-find (lambda (dir) + (and dir + (file-exists-p dir))) + (list default-directory + (expand-file-name "~/") + temporary-file-directory + (getenv "TMPDIR") + "/tmp/") + "/"))) + ,@body)) ;;; Matching and match data. @@ -4559,13 +4865,24 @@ rather than your caller's match data." '(set-match-data save-match-data-internal 'evaporate)))) (defun match-string (num &optional string) - "Return string of text matched by last search. -NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -Zero means the entire text matched by the whole regexp or whole string. -STRING should be given if the last search was by `string-match' on STRING. -If STRING is nil, the current buffer should be the same buffer -the search/match was performed in." + "Return the string of text matched by the previous search or regexp operation. +NUM specifies the number of the parenthesized sub-expression in the last +regexp whose match to return. Zero means return the text matched by the +entire regexp or the whole string. + +The return value is nil if NUMth pair didn't match anything, or if there +were fewer than NUM sub-expressions in the regexp used in the search. + +STRING should be given if the last search was by `string-match' +on STRING. If STRING is nil, the current buffer should be the +same buffer as the one in which the search/match was performed. + +Note that many functions in Emacs modify the match data, so this +function should be called \"close\" to the function that did the +regexp search. In particular, saying (for instance) +`M-: (looking-at \"[0-9]\") RET' followed by `M-: (match-string 0) RET' +interactively is seldom meaningful, since the Emacs command loop +may modify the match data." (declare (side-effect-free t)) (if (match-beginning num) (if string @@ -4641,14 +4958,12 @@ wherever possible, since it is slow." (defsubst looking-at-p (regexp) "\ Same as `looking-at' except this function does not change the match data." - (let ((inhibit-changing-match-data t)) - (looking-at regexp))) + (looking-at regexp t)) (defsubst string-match-p (regexp string &optional start) "\ Same as `string-match' except this function does not change the match data." - (let ((inhibit-changing-match-data t)) - (string-match regexp string start))) + (string-match regexp string start t)) (defun subregexp-context-p (regexp pos &optional start) "Return non-nil if POS is in a normal subregexp context in REGEXP. @@ -4808,7 +5123,7 @@ It understands Emacs Lisp quoting within STRING, such that (split-string-and-unquote (combine-and-quote-strings strs)) == strs The SEPARATOR regexp defaults to \"\\s-+\"." (let ((sep (or separator "\\s-+")) - (i (string-match "\"" string))) + (i (string-search "\"" string))) (if (null i) (split-string string sep t) ; no quoting: easy (append (unless (eq i 0) (split-string (substring string 0 i) sep t)) @@ -4831,25 +5146,25 @@ Unless optional argument INPLACE is non-nil, return a new string." (aset newstr i tochar))) newstr)) -(defun string-replace (fromstring tostring instring) - "Replace FROMSTRING with TOSTRING in INSTRING each time it occurs." +(defun string-replace (from-string to-string in-string) + "Replace FROM-STRING with TO-STRING in IN-STRING each time it occurs." (declare (pure t) (side-effect-free t)) - (when (equal fromstring "") + (when (equal from-string "") (signal 'wrong-length-argument '(0))) (let ((start 0) (result nil) pos) - (while (setq pos (string-search fromstring instring start)) + (while (setq pos (string-search from-string in-string start)) (unless (= start pos) - (push (substring instring start pos) result)) - (push tostring result) - (setq start (+ pos (length fromstring)))) + (push (substring in-string start pos) result)) + (push to-string result) + (setq start (+ pos (length from-string)))) (if (null result) ;; No replacements were done, so just return the original string. - instring + in-string ;; Get any remaining bit. - (unless (= start (length instring)) - (push (substring instring start) result)) + (unless (= start (length in-string)) + (push (substring in-string start) result)) (apply #'concat (nreverse result))))) (defun replace-regexp-in-string (regexp rep string &optional @@ -5168,7 +5483,7 @@ that can be added. If `buffer-invisibility-spec' isn't a list before calling this function, `buffer-invisibility-spec' will afterwards be a list with the value `(t ELEMENT)'. This means that if text exists -that invisibility values that aren't either `t' or ELEMENT, that +that invisibility values that aren't either t or ELEMENT, that text will become visible." (if (eq buffer-invisibility-spec t) (setq buffer-invisibility-spec (list t))) @@ -5178,8 +5493,8 @@ text will become visible." (defun remove-from-invisibility-spec (element) "Remove ELEMENT from `buffer-invisibility-spec'. If `buffer-invisibility-spec' isn't a list before calling this -function, it will be made into a list containing just `t' as the -only list member. This means that if text exists with non-`t' +function, it will be made into a list containing just t as the +only list member. This means that if text exists with non-t invisibility values, that text will become visible." (setq buffer-invisibility-spec (if (consp buffer-invisibility-spec) @@ -5453,6 +5768,7 @@ If HOOKVAR is nil, `mail-send-hook' is used. The properties used on SYMBOL are `composefunc', `sendfunc', `abortfunc', and `hookvar'." + (declare (indent defun)) (put symbol 'composefunc composefunc) (put symbol 'sendfunc sendfunc) (put symbol 'abortfunc (or abortfunc #'kill-buffer)) @@ -5889,7 +6205,7 @@ print the reporter message followed by the word \"done\". (,count 0) (,list ,(cadr spec))) (when (stringp ,prep) - (setq ,prep (make-progress-reporter ,prep 0 (1- (length ,list))))) + (setq ,prep (make-progress-reporter ,prep 0 (length ,list)))) (dolist (,(car spec) ,list) ,@body (progress-reporter-update ,prep (setq ,count (1+ ,count)))) @@ -6299,17 +6615,29 @@ seconds." This is intended for very simple filling while bootstrapping Emacs itself, and does not support all the customization options of fill.el (for example `fill-region')." - (if (< (string-width str) fill-column) + (if (< (length str) fill-column) str - (let ((fst (substring str 0 fill-column)) - (lst (substring str fill-column))) - (if (string-match ".*\\( \\(.+\\)\\)$" fst) - (setq fst (replace-match "\n\\2" nil nil fst 1))) + (let* ((limit (min fill-column (length str))) + (fst (substring str 0 limit)) + (lst (substring str limit))) + (cond ((string-match "\\( \\)$" fst) + (setq fst (replace-match "\n" nil nil fst 1))) + ((string-match "^ \\(.*\\)" lst) + (setq fst (concat fst "\n")) + (setq lst (match-string 1 lst))) + ((string-match ".*\\( \\(.+\\)\\)$" fst) + (setq lst (concat (match-string 2 fst) lst)) + (setq fst (replace-match "\n" nil nil fst 1)))) (concat fst (internal--fill-string-single-line lst))))) (defun internal--format-docstring-line (string &rest objects) - "Format a documentation string out of STRING and OBJECTS. -This is intended for internal use only." + "Format a single line from a documentation string out of STRING and OBJECTS. +Signal an error if STRING contains a newline. +This is intended for internal use only. Avoid using this for the +first line of a docstring; the first line should be a complete +sentence (see Info node `(elisp) Documentation Tips')." + (when (string-match "\n" string) + (error "Unable to fill string containing newline: %S" string)) (internal--fill-string-single-line (apply #'format string objects))) (defun json-available-p () @@ -6320,4 +6648,133 @@ This is intended for internal use only." (:success t) (json-unavailable nil)))) +(defun ensure-list (object) + "Return OBJECT as a list. +If OBJECT is already a list, return OBJECT itself. If it's +not a list, return a one-element list containing OBJECT." + (if (listp object) + object + (list object))) + +(defun define-keymap (&rest definitions) + "Create a new keymap and define KEY/DEFEFINITION pairs as key sequences. +The new keymap is returned. + +Options can be given as keywords before the KEY/DEFEFINITION +pairs. Available keywords are: + +:full If non-nil, create a chartable alist (see `make-keymap'). + If nil (i.e., the default), create a sparse keymap (see + `make-sparse-keymap'). + +:suppress If non-nil, the keymap will be suppressed (see `suppress-keymap'). + If `nodigits', treat digits like other chars. + +:parent If non-nil, this should be a keymap to use as the parent + (see `set-keymap-parent'). + +:keymap If non-nil, instead of creating a new keymap, the given keymap + will be destructively modified instead. + +:name If non-nil, this should be a string to use as the menu for + the keymap in case you use it as a menu with `x-popup-menu'. + +:prefix If non-nil, this should be a symbol to be used as a prefix + command (see `define-prefix-command'). If this is the case, + this symbol is returned instead of the map itself. + +KEY/DEFINITION pairs are as KEY and DEF in `define-key'. KEY can +also be the special symbol `:menu', in which case DEFINITION +should be a MENU form as accepted by `easy-menu-define'. + +\(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" + (declare (indent defun)) + (define-keymap--define definitions)) + +(defun define-keymap--define (definitions) + (let (full suppress parent name prefix keymap) + ;; Handle keywords. + (while (and definitions + (keywordp (car definitions)) + (not (eq (car definitions) :menu))) + (let ((keyword (pop definitions))) + (unless definitions + (error "Missing keyword value for %s" keyword)) + (let ((value (pop definitions))) + (pcase keyword + (:full (setq full value)) + (:keymap (setq keymap value)) + (:parent (setq parent value)) + (:suppress (setq suppress value)) + (:name (setq name value)) + (:prefix (setq prefix value)) + (_ (error "Invalid keyword: %s" keyword)))))) + + (when (and prefix + (or full parent suppress keymap)) + (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords")) + + (when (and keymap full) + (error "Invalid combination: :keymap with :full")) + + (let ((keymap (cond + (keymap keymap) + (prefix (define-prefix-command prefix nil name)) + (full (make-keymap name)) + (t (make-sparse-keymap name))))) + (when suppress + (suppress-keymap keymap (eq suppress 'nodigits))) + (when parent + (set-keymap-parent keymap parent)) + + ;; Do the bindings. + (while definitions + (let ((key (pop definitions))) + (unless definitions + (error "Uneven number of key/definition pairs")) + (let ((def (pop definitions))) + (if (eq key :menu) + (easy-menu-define nil keymap "" def) + (define-key keymap key def))))) + keymap))) + +(defmacro defvar-keymap (variable-name &rest defs) + "Define VARIABLE-NAME as a variable with a keymap definition. +See `define-keymap' for an explanation of the keywords and KEY/DEFINITION. + +In addition to the keywords accepted by `define-keymap', this +macro also accepts a `:doc' keyword, which (if present) is used +as the variable documentation string. + +\(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" + (declare (indent 1)) + (let ((opts nil) + doc) + (while (and defs + (keywordp (car defs)) + (not (eq (car defs) :menu))) + (let ((keyword (pop defs))) + (unless defs + (error "Uneven number of keywords")) + (if (eq keyword :doc) + (setq doc (pop defs)) + (push keyword opts) + (push (pop defs) opts)))) + (unless (zerop (% (length defs) 2)) + (error "Uneven number of key/definition pairs: %s" defs)) + `(defvar ,variable-name + (define-keymap--define (list ,@(nreverse opts) ,@defs)) + ,@(and doc (list doc))))) + +(defmacro with-delayed-message (args &rest body) + "Like `progn', but display MESSAGE if BODY takes longer than TIMEOUT seconds. +The MESSAGE form will be evaluated immediately, but the resulting +string will be displayed only if BODY takes longer than TIMEOUT seconds. + +\(fn (timeout message) &rest body)" + (declare (indent 1)) + `(funcall-with-delayed-message ,(car args) ,(cadr args) + (lambda () + ,@body))) + ;;; subr.el ends here |