diff options
Diffstat (limited to 'lisp/subr.el')
| -rw-r--r-- | lisp/subr.el | 605 |
1 files changed, 519 insertions, 86 deletions
diff --git a/lisp/subr.el b/lisp/subr.el index 921853de607..0b415d8b2c5 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -61,7 +61,8 @@ must be the first non-whitespace on a line. For more information, see Info node `(elisp)Declaring Functions'." (declare (advertised-calling-convention (fn file &optional arglist fileonly) nil)) - ;; Does nothing - byte-compile-declare-function does the work. + ;; Does nothing - `byte-compile-macroexpand-declare-function' does + ;; the work. nil) @@ -193,7 +194,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)))) @@ -206,6 +207,39 @@ Also see `local-variable-p'." (:success t) (void-variable nil))) +(defmacro buffer-local-set-state (&rest pairs) + "Like `setq-local', but allow restoring the previous state of locals later. +This macro returns an object that can be passed to `buffer-local-restore-state' +in order to restore the state of the local variables set via this macro. + +\(fn [VARIABLE VALUE]...)" + (declare (debug setq)) + (unless (zerop (mod (length pairs) 2)) + (error "PAIRS must have an even number of variable/value members")) + `(prog1 + (buffer-local-set-state--get ',pairs) + (setq-local ,@pairs))) + +(defun buffer-local-set-state--get (pairs) + (let ((states nil)) + (while pairs + (push (list (car pairs) + (and (boundp (car pairs)) + (local-variable-p (car pairs))) + (and (boundp (car pairs)) + (symbol-value (car pairs)))) + states) + (setq pairs (cddr pairs))) + (nreverse states))) + +(defun buffer-local-restore-state (states) + "Restore values of buffer-local variables recorded in STATES. +STATES should be an object returned by `buffer-local-set-state'." + (pcase-dolist (`(,variable ,local ,value) states) + (if local + (set variable value) + (kill-local-variable variable)))) + (defmacro push (newelt place) "Add NEWELT to the list stored in the generalized variable PLACE. This is morally equivalent to (setf PLACE (cons NEWELT PLACE)), @@ -242,18 +276,14 @@ change the list." (defmacro when (cond &rest body) "If COND yields non-nil, do BODY, else return nil. When COND yields non-nil, eval BODY forms sequentially and return -value of last one, or nil if there are none. - -\(fn COND BODY...)" +value of last one, or nil if there are none." (declare (indent 1) (debug t)) (list 'if cond (cons 'progn body))) (defmacro unless (cond &rest body) "If COND yields nil, do BODY, else return nil. When COND yields nil, eval BODY forms sequentially and return -value of last one, or nil if there are none. - -\(fn COND BODY...)" +value of last one, or nil if there are none." (declare (indent 1) (debug t)) (cons 'if (cons cond (cons nil body)))) @@ -411,7 +441,10 @@ To signal with MESSAGE without interpreting format characters like `%', `\\=`' and `\\='', use (error \"%s\" MESSAGE). In Emacs, the convention is that error messages start with a capital letter but *do not* end with a period. Please follow this convention -for the sake of consistency." +for the sake of consistency. + +To alter the look of the displayed error messages, you can use +the `command-error-function' variable." (declare (advertised-calling-convention (string &rest args) "23.1")) (signal 'error (list (apply #'format-message args)))) @@ -427,7 +460,10 @@ To signal with MESSAGE without interpreting format characters like `%', `\\=`' and `\\='', use (user-error \"%s\" MESSAGE). In Emacs, the convention is that error messages start with a capital letter but *do not* end with a period. Please follow this convention -for the sake of consistency." +for the sake of consistency. + +To alter the look of the displayed error messages, you can use +the `command-error-function' variable." (signal 'user-error (list (apply #'format-message format args)))) (defun define-error (name message &optional parent) @@ -929,15 +965,43 @@ side-effects, and the argument LIST is not modified." "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))) + (let ((res (key-parse keys))) + ;; For historical reasons, parse "C-x ( C-d C-x )" as "C-d", since + ;; `kbd' used to be a wrapper around `read-kbd-macro'. + (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 (cddr lres)) + (setq lres (nreverse lres)) + (setq lres (cddr lres)) + (nreverse 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." @@ -988,6 +1052,9 @@ PARENT if non-nil should be a keymap." (defun define-key-after (keymap key definition &optional after) "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. +This is a legacy function; see `keymap-set-after' for the +recommended function to use instead. + This is like `define-key' except that the binding for KEY is placed just after the binding for the event AFTER, instead of at the beginning of the map. Note that AFTER must be an event type (like KEY), NOT a command @@ -1000,6 +1067,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))) @@ -1130,8 +1198,17 @@ Subkeymaps may be modified but are not canonicalized." (setq map (map-keymap ;; -internal (lambda (key item) (if (consp key) - ;; Treat char-ranges specially. - (push (cons key item) ranges) + (if (= (car key) (1- (cdr key))) + ;; If we have a two-character range, then + ;; treat it as two separate characters + ;; (because this makes `describe-bindings' + ;; look better and shouldn't affect + ;; anything else). + (progn + (push (cons (car key) item) bindings) + (push (cons (cdr key) item) bindings)) + ;; Treat char-ranges specially. + (push (cons key item) ranges)) (push (cons key item) bindings))) map))) ;; Create the new map. @@ -1157,6 +1234,9 @@ Subkeymaps may be modified but are not canonicalized." (defun keyboard-translate (from to) "Translate character FROM to TO on the current terminal. +This is a legacy function; see `keymap-translate' for the +recommended function to use instead. + This function creates a `keyboard-translate-table' if necessary and then modifies one entry in it." (or (char-table-p keyboard-translate-table) @@ -1168,6 +1248,9 @@ and then modifies one entry in it." (defun global-set-key (key command) "Give KEY a global binding as COMMAND. +This is a legacy function; see `keymap-global-set' for the +recommended function to use instead. + COMMAND is the command definition to use; usually it is a symbol naming an interactively-callable function. KEY is a key sequence; noninteractively, it is a string or vector @@ -1189,6 +1272,9 @@ that you make with this function." (defun local-set-key (key command) "Give KEY a local binding as COMMAND. +This is a legacy function; see `keymap-local-set' for the +recommended function to use instead. + COMMAND is the command definition to use; usually it is a symbol naming an interactively-callable function. KEY is a key sequence; noninteractively, it is a string or vector @@ -1207,12 +1293,18 @@ cases is shared with all other buffers in the same major mode." (defun global-unset-key (key) "Remove global binding of KEY. +This is a legacy function; see `keymap-global-unset' for the +recommended function to use instead. + KEY is a string or vector representing a sequence of keystrokes." (interactive "kUnset key globally: ") (global-set-key key nil)) (defun local-unset-key (key) "Remove local binding of KEY. +This is a legacy function; see `keymap-local-unset' for the +recommended function to use instead. + KEY is a string or vector representing a sequence of keystrokes." (interactive "kUnset key locally: ") (if (current-local-map) @@ -1221,6 +1313,9 @@ KEY is a string or vector representing a sequence of keystrokes." (defun local-key-binding (keys &optional accept-default) "Return the binding for command KEYS in current local keymap only. +This is a legacy function; see `keymap-local-binding' for the +recommended function to use instead. + KEYS is a string or vector, a sequence of keystrokes. The binding is probably a symbol with a function definition. @@ -1232,6 +1327,9 @@ about this." (defun global-key-binding (keys &optional accept-default) "Return the binding for command KEYS in current global keymap only. +This is a legacy function; see `keymap-global-binding' for the +recommended function to use instead. + KEYS is a string or vector, a sequence of keystrokes. The binding is probably a symbol with a function definition. This function's return values are the same as those of `lookup-key' @@ -1250,6 +1348,9 @@ about this." (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. +This is a legacy function; see `keymap-substitute' for the +recommended function to use instead. + In other words, OLDDEF is replaced with NEWDEF wherever it appears. Alternatively, if optional fourth argument OLDMAP is specified, we redefine in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. @@ -1752,6 +1853,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") @@ -1778,6 +1880,9 @@ This was used internally by quail.el and keyboard.c in Emacs 27. It does nothing in Emacs 28.") (make-obsolete-variable 'inhibit--record-char nil "28.1") +(define-obsolete-function-alias 'compare-window-configurations + #'window-configuration-equal-p "29.1") + ;; We can't actually make `values' obsolete, because that will result ;; in warnings when using `values' in let-bindings. ;;(make-obsolete-variable 'values "no longer used" "28.1") @@ -1852,7 +1957,9 @@ performance impact when running `add-hook' and `remove-hook'." (set (make-local-variable hook) (list t))) ;; Detect the case where make-local-variable was used on a hook ;; and do what we used to do. - (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook))) + (when (and (local-variable-if-set-p hook) + (not (and (consp (symbol-value hook)) + (memq t (symbol-value hook))))) (setq local t))) (let ((hook-value (if local (symbol-value hook) (default-value hook)))) ;; If the hook value is a single function, turn it into a list. @@ -1860,26 +1967,34 @@ performance impact when running `add-hook' and `remove-hook'." (setq hook-value (list hook-value))) ;; Do the actual addition if necessary (unless (member function hook-value) - (when (stringp function) ;FIXME: Why? - (setq function (purecopy function))) - ;; All those `equal' tests performed between functions can end up being - ;; costly since those functions may be large recursive and even cyclic - ;; structures, so we index `hook--depth-alist' with `eq'. (bug#46326) - (when (or (get hook 'hook--depth-alist) (not (zerop depth))) - ;; Note: The main purpose of the above `when' test is to avoid running - ;; this `setf' before `gv' is loaded during bootstrap. - (push (cons function depth) (get hook 'hook--depth-alist))) - (setq hook-value - (if (< 0 depth) - (append hook-value (list function)) - (cons function hook-value))) - (let ((depth-alist (get hook 'hook--depth-alist))) - (when depth-alist - (setq hook-value - (sort (if (< 0 depth) hook-value (copy-sequence hook-value)) - (lambda (f1 f2) - (< (alist-get f1 depth-alist 0 nil #'eq) - (alist-get f2 depth-alist 0 nil #'eq)))))))) + (let ((depth-sym (get hook 'hook--depth-alist))) + ;; While the `member' test above has to use `equal' for historical + ;; reasons, `equal' is a performance problem on large/cyclic functions, + ;; so we index `hook--depth-alist' with `eql'. (bug#46326) + (unless (zerop depth) + (unless depth-sym + (setq depth-sym (make-symbol "depth-alist")) + (set depth-sym nil) + (setf (get hook 'hook--depth-alist) depth-sym)) + (if local (make-local-variable depth-sym)) + (setf (alist-get function + (if local (symbol-value depth-sym) + (default-value depth-sym)) + 0) + depth)) + (setq hook-value + (if (< 0 depth) + (append hook-value (list function)) + (cons function hook-value))) + (when depth-sym + (let ((depth-alist (if local (symbol-value depth-sym) + (default-value depth-sym)))) + (when depth-alist + (setq hook-value + (sort (if (< 0 depth) hook-value (copy-sequence hook-value)) + (lambda (f1 f2) + (< (alist-get f1 depth-alist 0 nil #'eq) + (alist-get f2 depth-alist 0 nil #'eq)))))))))) ;; Set the actual variable (if local (progn @@ -1927,7 +2042,7 @@ one will be removed." (format "%s hook to remove: " (if local "Buffer-local" "Global")) fn-alist - nil t) + nil t nil 'set-variable-value-history) fn-alist nil nil #'string=))) (list hook function local))) (or (boundp hook) (set hook nil)) @@ -1952,9 +2067,14 @@ one will be removed." (when old-fun ;; Remove auxiliary depth info to avoid leaks (bug#46414) ;; and to avoid the list growing too long. - (let* ((depths (get hook 'hook--depth-alist)) - (di (assq old-fun depths))) - (when di (put hook 'hook--depth-alist (delq di depths))))) + (let* ((depth-sym (get hook 'hook--depth-alist)) + (depth-alist (if depth-sym (if local (symbol-value depth-sym) + (default-value depth-sym)))) + (di (assq old-fun depth-alist))) + (when di + (setf (if local (symbol-value depth-sym) + (default-value depth-sym)) + (remq di depth-alist))))) ;; If the function is on the global hook, we need to shadow it locally ;;(when (and local (member function (default-value hook)) ;; (not (member (cons 'not function) hook-value))) @@ -2116,7 +2236,7 @@ can do the job." (not (macroexp-const-p append))) exp (let* ((sym (cadr list-var)) - (append (eval append)) + (append (eval append lexical-binding)) (msg (format-message "`add-to-list' can't use lexical var `%s'; use `push' or `cl-pushnew'" sym)) @@ -2303,6 +2423,102 @@ Affects only hooks run in the current buffer." (let ((delay-mode-hooks t)) ,@body))) +;;; `when-let' and friends. + +(defun internal--build-binding (binding prev-var) + "Check and build a single BINDING with PREV-VAR." + (setq binding + (cond + ((symbolp binding) + (list binding binding)) + ((null (cdr binding)) + (list (make-symbol "s") (car binding))) + (t binding))) + (when (> (length binding) 2) + (signal 'error + (cons "`let' bindings can have only one value-form" binding))) + (let ((var (car binding))) + `(,var (and ,prev-var ,(cadr binding))))) + +(defun internal--build-bindings (bindings) + "Check and build conditional value forms for BINDINGS." + (let ((prev-var t)) + (mapcar (lambda (binding) + (let ((binding (internal--build-binding binding prev-var))) + (setq prev-var (car binding)) + binding)) + bindings))) + +(defmacro if-let* (varlist then &rest else) + "Bind variables according to VARLIST and evaluate THEN or ELSE. +This is like `if-let' but doesn't handle a VARLIST of the form +\(SYMBOL SOMETHING) specially." + (declare (indent 2) + (debug ((&rest [&or symbolp (symbolp form) (form)]) + body))) + (if varlist + `(let* ,(setq varlist (internal--build-bindings varlist)) + (if ,(caar (last varlist)) + ,then + ,@else)) + `(let* () ,then))) + +(defmacro when-let* (varlist &rest body) + "Bind variables according to VARLIST and conditionally evaluate BODY. +This is like `when-let' but doesn't handle a VARLIST of the form +\(SYMBOL SOMETHING) specially." + (declare (indent 1) (debug if-let*)) + (list 'if-let* varlist (macroexp-progn body))) + +(defmacro and-let* (varlist &rest body) + "Bind variables according to VARLIST and conditionally evaluate BODY. +Like `when-let*', except if BODY is empty and all the bindings +are non-nil, then the result is non-nil." + (declare (indent 1) (debug if-let*)) + (let (res) + (if varlist + `(let* ,(setq varlist (internal--build-bindings varlist)) + (when ,(setq res (caar (last varlist))) + ,@(or body `(,res)))) + `(let* () ,@(or body '(t)))))) + +(defmacro if-let (spec then &rest else) + "Bind variables according to SPEC and evaluate THEN or ELSE. +Evaluate each binding in turn, as in `let*', stopping if a +binding value is nil. If all are non-nil return the value of +THEN, otherwise the last form in ELSE. + +Each element of SPEC is a list (SYMBOL VALUEFORM) that binds +SYMBOL to the value of VALUEFORM. An element can additionally be +of the form (VALUEFORM), which is evaluated and checked for nil; +i.e. SYMBOL can be omitted if only the test result is of +interest. It can also be of the form SYMBOL, then the binding of +SYMBOL is checked for nil. + +As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) +like \((SYMBOL SOMETHING)). This exists for backward compatibility +with an old syntax that accepted only one binding." + (declare (indent 2) + (debug ([&or (symbolp form) ; must be first, Bug#48489 + (&rest [&or symbolp (symbolp form) (form)])] + body))) + (when (and (<= (length spec) 2) + (not (listp (car spec)))) + ;; Adjust the single binding case + (setq spec (list spec))) + (list 'if-let* spec then (macroexp-progn else))) + +(defmacro when-let (spec &rest body) + "Bind variables according to SPEC and conditionally evaluate BODY. +Evaluate each binding in turn, stopping if a binding value is nil. +If all are non-nil, return the value of the last form in BODY. + +The variable list SPEC is the same as in `if-let'." + (declare (indent 1) (debug if-let)) + (list 'if-let spec (macroexp-progn body))) + + + ;; PUBLIC: find if the current mode derives from another. (defun provided-mode-derived-p (mode &rest modes) @@ -2651,7 +2867,8 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'." (defun memory-limit () "Return an estimate of Emacs virtual memory usage, divided by 1024." - (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0)) + (let ((default-directory temporary-file-directory)) + (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0))) ;;;; Input and display facilities. @@ -2665,7 +2882,7 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'." (defconst read-key-full-map (let ((map (make-sparse-keymap))) - (define-key map [t] 'dummy) + (define-key map [t] #'ignore) ;Dummy binding. ;; ESC needs to be unbound so that escape sequences in ;; `input-decode-map' are still processed by `read-key-sequence'. @@ -2847,7 +3064,8 @@ DEFAULT specifies a default value to return if the user just types RET. The value of DEFAULT is inserted into PROMPT. HIST specifies a history list variable. See `read-from-minibuffer' for details of the HIST argument. -This function is used by the `interactive' code letter `n'." + +This function is used by the `interactive' code letter \"n\"." (let ((n nil) (default1 (if (consp default) (car default) default))) (when default1 @@ -3079,7 +3297,7 @@ Optional argument CHARS, if non-nil, should be a list of characters; the function will ignore any input that is not one of CHARS. Optional argument HISTORY, if non-nil, should be a symbol that specifies the history list variable to use for navigating in input -history using `M-p' and `M-n', with `RET' to select a character from +history using \\`M-p' and \\`M-n', with \\`RET' to select a character from history. If you bind the variable `help-form' to a non-nil value while calling this function, then pressing `help-char' @@ -3207,6 +3425,15 @@ 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.") +(defvar from--tty-menu-p nil + "Non-nil means the current command was invoked from a TTY menu.") +(defun use-dialog-box-p () + "Say whether the current command should prompt the user via a dialog box." + (and last-input-event ; not during startup + (or (listp last-nonmenu-event) ; invoked by a mouse event + from--tty-menu-p) ; invoked via TTY menu + use-dialog-box)) + (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\". @@ -3266,10 +3493,7 @@ like) while `y-or-n-p' is running)." ((and (member str '("h" "H")) help-form) (print help-form)) (t (setq temp-prompt (concat "Please answer y or n. " prompt)))))))) - ((and (display-popup-menus-p) - last-input-event ; not during startup - (listp last-nonmenu-event) - use-dialog-box) + ((use-dialog-box-p) (setq prompt (funcall padded prompt t) answer (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip))))) (y-or-n-p-use-read-key @@ -3370,6 +3594,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. @@ -3569,6 +3816,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 @@ -3660,14 +3910,18 @@ Note: :data and :device are currently not supported on Windows." (declare-function w32-shell-dos-semantics "w32-fns" nil) -(defun shell-quote-argument (argument) +(defun shell-quote-argument (argument &optional posix) "Quote ARGUMENT for passing as argument to an inferior shell. This function is designed to work with the syntax of your system's standard shell, and might produce incorrect results with unusual shells. -See Info node `(elisp)Security Considerations'." - (cond - ((eq system-type 'ms-dos) +See Info node `(elisp)Security Considerations'. + +If the optional POSIX argument is non-nil, ARGUMENT is quoted +according to POSIX shell quoting rules, regardless of the +system's shell." +(cond + ((and (not posix) (eq system-type 'ms-dos)) ;; Quote using double quotes, but escape any existing quotes in ;; the argument with backslashes. (let ((result "") @@ -3682,7 +3936,7 @@ See Info node `(elisp)Security Considerations'." start (1+ end)))) (concat "\"" result (substring argument start) "\""))) - ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics)) + ((and (not posix) (eq system-type 'windows-nt) (w32-shell-dos-semantics)) ;; First, quote argument so that CommandLineToArgvW will ;; understand it. See @@ -3825,7 +4079,12 @@ remove properties specified by `yank-excluded-properties'." This function is like `insert', except it honors the variables `yank-handled-properties' and `yank-excluded-properties', and the -`yank-handler' text property, in the way that `yank' does." +`yank-handler' text property, in the way that `yank' does. + +It also runs the string through `yank-transform-functions'." + ;; Allow altering the yank string. + (run-hook-wrapped 'yank-transform-functions + (lambda (f) (setq string (funcall f string)))) (let (to) (while (setq to (next-single-property-change 0 'yank-handler string)) (insert-for-yank-1 (substring string 0 to)) @@ -3989,7 +4248,7 @@ BUFFER is the buffer (or buffer name) to associate with the process. Process output goes at end of that buffer, unless you specify an output stream or filter function to handle the output. BUFFER may be also nil, meaning that this process is not associated - with any buffer + with any buffer. COMMAND is the shell command to run." ;; We used to use `exec' to replace the shell with the command, ;; but that failed to handle (...) and semicolon, etc. @@ -4226,11 +4485,13 @@ in which case `save-window-excursion' cannot help." (defmacro with-output-to-temp-buffer (bufname &rest body) "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. -This construct makes buffer BUFNAME empty before running BODY. -It does not make the buffer current for BODY. -Instead it binds `standard-output' to that buffer, so that output -generated with `prin1' and similar functions in BODY goes into -the buffer. +This is a convenience macro meant for displaying help buffers and +the like. It empties the BUFNAME buffer before evaluating BODY +and disables undo in that buffer. + +It does not make the buffer current for BODY. Instead it binds +`standard-output' to that buffer, so that output generated with +`prin1' and similar functions in BODY goes into the buffer. At the end of BODY, this marks buffer BUFNAME unmodified and displays it in a window, but does not select it. The normal way to do this is @@ -4356,8 +4617,9 @@ of that nature." (unwind-protect (progn ,@body) - (unless ,modified - (restore-buffer-modified-p nil)))))) + (when (or (not ,modified) + (eq ,modified 'autosaved)) + (restore-buffer-modified-p ,modified)))))) (defmacro with-output-to-string (&rest body) "Execute BODY, return the text it sent to `standard-output', as a string." @@ -4386,12 +4648,7 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)" ;; Without this, it will not be handled until the next function ;; call, and that might allow it to exit thru a condition-case ;; 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)) + (eval '(ignore nil) t)))) (defmacro while-no-input (&rest body) "Execute BODY only as long as there's no pending input. @@ -4451,19 +4708,21 @@ It should contain a single %-sequence; e.g., \"Error: %S\". If `debug-on-error' is non-nil, run BODY without catching its errors. This is to be used around code that is not expected to signal an error -but that should be robust in the unexpected case that an error is signaled. - -For backward compatibility, if FORMAT is not a constant string, it -is assumed to be part of BODY, in which case the message format -used is \"Error: %S\"." +but that should be robust in the unexpected case that an error is signaled." (declare (debug t) (indent 1)) - (let ((err (make-symbol "err")) - (format (if (and (stringp format) body) format - (prog1 "Error: %S" - (if format (push format body)))))) - `(condition-case-unless-debug ,err - ,(macroexp-progn body) - (error (message ,format ,err) nil)))) + (let* ((err (make-symbol "err")) + (orig-body body) + (format (if (and (stringp format) body) format + (prog1 "Error: %S" + (if format (push format body))))) + (exp + `(condition-case-unless-debug ,err + ,(macroexp-progn body) + (error (message ,format ,err) nil)))) + (if (eq orig-body body) exp + ;; The use without `format' is obsolete, let's warn when we bump + ;; into any such remaining uses. + (macroexp-warn-and-return "Missing format argument" exp nil nil format)))) (defmacro combine-after-change-calls (&rest body) "Execute BODY, but don't call the after-change functions till the end. @@ -4765,14 +5024,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. @@ -5577,6 +5834,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)) @@ -5791,6 +6049,10 @@ to deactivate this transient map, regardless of KEEP-PRED." t) ((eq t keep-pred) (let ((mc (lookup-key map (this-command-keys-vector)))) + ;; We may have a remapped command, so chase + ;; down that. + (when (and mc (symbolp mc)) + (setq mc (or (command-remapping mc) mc))) ;; If the key is unbound `this-command` is ;; nil and so is `mc`. (and mc (eq this-command mc)))) @@ -6464,4 +6726,175 @@ not a list, return a one-element list containing OBJECT." object (list object))) +(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))) + +(defun function-alias-p (func &optional noerror) + "Return nil if FUNC is not a function alias. +If FUNC is a function alias, return the function alias chain. + +If the function alias chain contains loops, an error will be +signalled. If NOERROR, the non-loop parts of the chain is returned." + (declare (side-effect-free t)) + (let ((chain nil) + (orig-func func)) + (nreverse + (catch 'loop + (while (and (symbolp func) + (setq func (symbol-function func)) + (symbolp func)) + (when (or (memq func chain) + (eq func orig-func)) + (if noerror + (throw 'loop chain) + (signal 'cyclic-function-indirection (list orig-func)))) + (push func chain)) + chain)))) + +(defun readablep (object) + "Say whether OBJECT has a readable syntax. +This means that OBJECT can be printed out and then read back +again by the Lisp reader. This function returns nil if OBJECT is +unreadable, and the printed representation (from `prin1') of +OBJECT if it is readable." + (declare (side-effect-free t)) + (catch 'unreadable + (let ((print-unreadable-function + (lambda (_object _escape) + (throw 'unreadable nil)))) + (prin1-to-string object)))) + +(defun delete-line () + "Delete the current line." + (delete-region (line-beginning-position) + (progn + (forward-line 1) + (point)))) + +(defun ensure-empty-lines (&optional lines) + "Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. + +If called interactively, LINES is given by the prefix argument. + +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. + +If point is not at the beginning of a line, a newline character +is inserted before adjusting the number of empty lines." + (interactive "p") + (unless (bolp) + (insert "\n")) + (let ((lines (or lines 1)) + (start (save-excursion + (if (re-search-backward "[^\n]" nil t) + (+ (point) 2) + (point-min))))) + (cond + ((> (- (point) start) lines) + (delete-region (point) (- (point) (- (point) start lines)))) + ((< (- (point) start) lines) + (insert (make-string (- lines (- (point) start)) ?\n)))))) + +(defun string-lines (string &optional omit-nulls keep-newlines) + "Split STRING into a list of lines. +If OMIT-NULLS, empty lines will be removed from the results. +If KEEP-NEWLINES, don't strip trailing newlines from the result +lines." + (if (equal string "") + (if omit-nulls + nil + (list "")) + (let ((lines nil) + (start 0)) + (while (< start (length string)) + (let ((newline (string-search "\n" string start))) + (if newline + (progn + (when (or (not omit-nulls) + (not (= start newline))) + (let ((line (substring string start + (if keep-newlines + (1+ newline) + newline)))) + (when (not (and keep-newlines omit-nulls + (equal line "\n"))) + (push line lines)))) + (setq start (1+ newline))) + ;; No newline in the remaining part. + (if (zerop start) + ;; Avoid a string copy if there are no newlines at all. + (push string lines) + (push (substring string start) lines)) + (setq start (length string))))) + (nreverse lines)))) + +(defun buffer-match-p (condition buffer-or-name &optional arg) + "Return non-nil if BUFFER-OR-NAME matches CONDITION. +CONDITION is either: +- a regular expression, to match a buffer name, +- a predicate function that takes a buffer object and ARG as + arguments, and returns non-nil if the buffer matches, +- a cons-cell, where the car describes how to interpret the cdr. + The car can be one of the following: + * `major-mode': the buffer matches if the buffer's major + mode is derived from the major mode denoted by the cons-cell's + cdr + * `not': the cdr is interpreted as a negation of a condition. + * `and': the cdr is a list of recursive conditions, that all have + to be met. + * `or': the cdr is a list of recursive condition, of which at + least one has to be met." + (letrec + ((buffer (get-buffer buffer-or-name)) + (match + (lambda (conditions) + (catch 'match + (dolist (condition conditions) + (when (cond + ((stringp condition) + (string-match-p condition (buffer-name buffer))) + ((functionp condition) + (if (eq 1 (cdr (func-arity condition))) + (funcall condition buffer) + (funcall condition buffer arg))) + ((eq (car-safe condition) 'major-mode) + (provided-mode-derived-p + (buffer-local-value 'major-mode buffer) + (cdr condition))) + ((eq (car-safe condition) 'not) + (not (funcall match (cdr condition)))) + ((eq (car-safe condition) 'or) + (funcall match (cdr condition))) + ((eq (car-safe condition) 'and) + (catch 'fail + (dolist (c (cdr conditions)) + (unless (funcall match c) + (throw 'fail nil))) + t))) + (throw 'match t))))))) + (funcall match (list condition)))) + +(defun match-buffers (condition &optional buffers arg) + "Return a list of buffers that match CONDITION. +See `buffer-match' for details on CONDITION. By default all +buffers are checked, this can be restricted by passing an +optional argument BUFFERS, set to a list of buffers to check. +ARG is passed to `buffer-match', for predicate conditions in +CONDITION." + (let (bufs) + (dolist (buf (or buffers (buffer-list))) + (when (buffer-match-p condition (get-buffer buf) arg) + (push buf bufs))) + bufs)) + ;;; subr.el ends here |