;;; compat-29.el --- Functionality added in Emacs 29.1 -*- lexical-binding: t; -*- ;; Copyright (C) 2021-2023 Free Software Foundation, Inc. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; Functionality added in Emacs 29.1, needed by older Emacs versions. ;;; Code: (eval-when-compile (load "compat-macs.el" nil t t)) (compat-require compat-28 "28.1") ;; Preloaded in loadup.el ;; TODO Update to 29.1 as soon as the Emacs emacs-29 branch version bumped (compat-require seq "29.0") ;; ;; TODO Update to 29.1 as soon as the Emacs emacs-29 branch version bumped (compat-version "29.0") ;;;; Defined in xdisp.c (compat-defun get-display-property (position prop &optional object properties) ;; "Get the value of the `display' property PROP at POSITION. If OBJECT, this should be a buffer or string where the property is fetched from. If omitted, OBJECT defaults to the current buffer. If PROPERTIES, look for value of PROP in PROPERTIES instead of the properties at POSITION." (if properties (unless (listp properties) (signal 'wrong-type-argument (list 'listp properties))) (setq properties (get-text-property position 'display object))) (cond ((vectorp properties) (catch 'found (dotimes (i (length properties)) (let ((ent (aref properties i))) (when (eq (car ent) prop) (throw 'found (cadr ent ))))))) ((consp (car properties)) (condition-case nil (cadr (assq prop properties)) ;; Silently handle improper lists: (wrong-type-argument nil))) ((and (consp (cdr properties)) (eq (car properties) prop)) (cadr properties)))) ;;;; Defined in fns.c (compat-defun ntake (n list) ;; "Modify LIST to keep only the first N elements. If N is zero or negative, return nil. If N is greater or equal to the length of LIST, return LIST unmodified. Otherwise, return LIST after truncating it." (and (> n 0) (let ((cons (nthcdr (1- n) list))) (when cons (setcdr cons nil)) list))) (compat-defun take (n list) ;; "Return the first N elements of LIST. If N is zero or negative, return nil. If N is greater or equal to the length of LIST, return LIST (or a copy)." (declare (pure t) (side-effect-free t)) (let (copy) (while (and (< 0 n) list) (push (pop list) copy) (setq n (1- n))) (nreverse copy))) (compat-defun string-equal-ignore-case (string1 string2) ;; "Like `string-equal', but case-insensitive. Upper-case and lower-case letters are treated as equal. Unibyte strings are converted to multibyte for comparison." (declare (pure t) (side-effect-free t)) (eq t (compare-strings string1 0 nil string2 0 nil t))) (compat-defun plist-get (plist prop &optional predicate) ;; "Handle optional argument PREDICATE." :extended t (if (or (null predicate) (eq predicate 'eq)) (plist-get plist prop) (catch 'found (while (consp plist) (when (funcall predicate prop (car plist)) (throw 'found (cadr plist))) (setq plist (cddr plist)))))) (compat-defun plist-put (plist prop val &optional predicate) ;; "Handle optional argument PREDICATE." :extended t (if (or (null predicate) (eq predicate 'eq)) (plist-put plist prop val) (catch 'found (let ((tail plist)) (while (consp tail) (when (funcall predicate prop (car tail)) (setcar (cdr tail) val) (throw 'found plist)) (setq tail (cddr tail)))) (nconc plist (list prop val))))) (compat-defun plist-member (plist prop &optional predicate) ;; "Handle optional argument PREDICATE." :extended t (if (or (null predicate) (eq predicate 'eq)) (plist-member plist prop) (catch 'found (while (consp plist) (when (funcall predicate prop (car plist)) (throw 'found plist)) (setq plist (cddr plist)))))) ;;;; Defined in gv.el (compat-guard t ;; (gv-define-expander compat--plist-get (lambda (do plist prop &optional predicate) (macroexp-let2 macroexp-copyable-p key prop (gv-letplace (getter setter) plist (macroexp-let2 nil p `(cdr (compat--plist-member ,getter ,key ,predicate)) (funcall do `(car ,p) (lambda (val) `(if ,p (setcar ,p ,val) ,(funcall setter `(cons ,key (cons ,val ,getter))))))))))) (unless (get 'plist-get 'gv-expander) (put 'plist-get 'gv-expander (get 'compat--plist-get 'gv-expander)))) ;;;; Defined in editfns.c (compat-defun pos-bol (&optional n) ;; "Return the position of the first character on the current line. With optional argument N, scan forward N - 1 lines first. If the scan reaches the end of the buffer, return that position. This function ignores text display directionality; it returns the position of the first character in logical order, i.e. the smallest character position on the logical line. See `vertical-motion' for movement by screen lines. This function does not move point. Also see `line-beginning-position'." (declare (side-effect-free t)) (let ((inhibit-field-text-motion t)) (line-beginning-position n))) (compat-defun pos-eol (&optional n) ;; "Return the position of the last character on the current line. With argument N not nil or 1, move forward N - 1 lines first. If scan reaches end of buffer, return that position. This function ignores text display directionality; it returns the position of the last character in logical order, i.e. the largest character position on the line. This function does not move point. Also see `line-end-position'." (declare (side-effect-free t)) (let ((inhibit-field-text-motion t)) (line-end-position n))) ;;;; Defined in subr.el (compat-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. NOTE: The compatibility function never displays the message, which is not problematic since the only effect of the function is to display a progress message to the user. Backporting this feature is not possible, since the implementation is directly baked into the Elisp interpreter. \(fn (timeout message) &rest body)" (declare (indent 1)) (macroexp-progn body)) (compat-defun funcall-with-delayed-message (timeout message function) ;; "Like `funcall', but display MESSAGE if FUNCTION takes longer than TIMEOUT. TIMEOUT is a number of seconds, and can be an integer or a floating point number. If FUNCTION takes less time to execute than TIMEOUT seconds, MESSAGE is not displayed. NOTE: The compatibility function never displays the message, which is not problematic since the only effect of the function is to display a progress message to the user. Backporting this feature is not possible, since the implementation is directly baked into the Elisp interpreter." (ignore timeout message) (funcall function)) (compat-defun string-lines (string &optional omit-nulls keep-newlines) ;; "Handle additional KEEP-NEWLINES argument." :extended "28.1" (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))) (if (zerop start) (push string lines) (push (substring string start) lines)) (setq start (length string))))) (nreverse lines)))) (compat-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 error-free)) (ignore-errors (equal object (read (prin1-to-string object))))) (compat-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'." (dolist (state states) (if (cadr state) (set (car state) (caddr state)) (kill-local-variable (car state))))) (compat-defun buffer-local-set-state--get (pairs) ;; "Internal helper function." (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))) (compat-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) (,(if (fboundp 'compat--setq-local) 'compat--setq-local 'setq-local) ,@pairs))) (compat-defun list-of-strings-p (object) ;; "Return t if OBJECT is nil or a list of strings." (declare (pure t) (side-effect-free t)) (while (and (consp object) (stringp (car object))) (setq object (cdr object))) (null object)) (compat-defun plistp (object) ;; "Non-nil if and only if OBJECT is a valid plist." (let ((len (proper-list-p object))) (and len (zerop (% len 2))))) (compat-defun delete-line () ;; "Delete the current line." (delete-region (pos-bol) (pos-bol 2))) (compat-defmacro with-restriction (start end &rest rest) ;; "Execute BODY with restrictions set to START and END. The current restrictions, if any, are restored upon return. When the optional :label LABEL argument is present, in which LABEL is a symbol, inside BODY, `narrow-to-region' and `widen' can be used only within the START and END limits. To gain access to other portions of the buffer, use `without-restriction' with the same LABEL argument. \(fn START END [:label LABEL] BODY)" (declare (indent 0) (debug t)) `(save-restriction (narrow-to-region ,start ,end) ;; Locking is ignored ,@(if (eq (car rest) :label) (cddr rest) rest))) (compat-defmacro without-restriction (&rest rest) ;; "Execute BODY without restrictions. The current restrictions, if any, are restored upon return. When the optional :label LABEL argument is present, the restrictions set by `with-restriction' with the same LABEL argument are lifted. \(fn [:label LABEL] BODY)" (declare (indent 0) (debug t)) `(save-restriction (widen) ;; Locking is ignored ,@(if (eq (car rest) :label) (cddr rest) rest))) (compat-defmacro with-memoization (place &rest code) ;; "Return the value of CODE and stash it in PLACE. If PLACE's value is non-nil, then don't bother evaluating CODE and return the value found in PLACE instead." (declare (indent 1)) (gv-letplace (getter setter) place `(or ,getter ,(macroexp-let2 nil val (macroexp-progn code) `(progn ,(funcall setter val) ,val))))) (compat-defalias string-split split-string) ;; (compat-defun compiled-function-p (object) ;; "Return non-nil if OBJECT is a function that has been compiled. Does not distinguish between functions implemented in machine code or byte-code." (or (subrp object) (byte-code-function-p object))) (compat-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)))) (compat-defun buffer-match-p (condition buffer-or-name &optional arg) ;; "Return non-nil if BUFFER-OR-NAME matches CONDITION. CONDITION is either: - the symbol t, to always match, - the symbol nil, which never matches, - 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: * `derived-mode': the buffer matches if the buffer's major mode is derived from the major mode in the cons-cell's cdr. * `major-mode': the buffer matches if the buffer's major mode is eq to the cons-cell's cdr. Prefer using `derived-mode' instead when both can work. * `not': the cadr 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 ((eq condition t)) ((stringp condition) (string-match-p condition (buffer-name buffer))) ((functionp condition) (condition-case nil (funcall condition buffer) (wrong-number-of-arguments (funcall condition buffer arg)))) ((eq (car-safe condition) 'major-mode) (eq (buffer-local-value 'major-mode buffer) (cdr condition))) ((eq (car-safe condition) 'derived-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 condition)) (unless (funcall match (list c)) (throw 'fail nil))) t))) (throw 'match t))))))) (funcall match (list condition)))) (compat-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)) (compat-defvar set-transient-map-timeout nil ;; "Timeout in seconds for deactivation of a transient keymap. If this is a number, it specifies the amount of idle time after which to deactivate the keymap set by `set-transient-map', thus overriding the value of the TIMEOUT argument to that function.") (compat-defvar set-transient-map-timer nil ;; "Timer for `set-transient-map-timeout'.") (declare-function format-spec "format-spec") (compat-defun set-transient-map (map &optional keep-pred on-exit message timeout) ;; "Handle the optional arguments MESSAGE and TIMEOUT." :extended t (unless (fboundp 'format-spec) (require 'format-spec)) (let* ((timeout (or set-transient-map-timeout timeout)) (message (when message (let (keys) (map-keymap (lambda (key cmd) (and cmd (push key keys))) map) (format-spec (if (stringp message) message "Repeat with %k") `((?k . ,(mapconcat (lambda (key) (substitute-command-keys (format "\\`%s'" (key-description (vector key))))) keys ", "))))))) (clearfun (make-symbol "clear-transient-map")) (exitfun (lambda () (internal-pop-keymap map 'overriding-terminal-local-map) (remove-hook 'pre-command-hook clearfun) (when message (message "")) (when set-transient-map-timer (cancel-timer set-transient-map-timer)) (when on-exit (funcall on-exit))))) (fset clearfun (lambda () (with-demoted-errors "set-transient-map PCH: %S" (if (cond ((null keep-pred) nil) ((and (not (eq map (cadr overriding-terminal-local-map))) (memq map (cddr overriding-terminal-local-map))) t) ((eq t keep-pred) (let ((mc (lookup-key map (this-command-keys-vector)))) (when (and mc (symbolp mc)) (setq mc (or (command-remapping mc) mc))) (and mc (eq this-command mc)))) (t (funcall keep-pred))) (when message (message "%s" message)) (funcall exitfun))))) (add-hook 'pre-command-hook clearfun) (internal-push-keymap map 'overriding-terminal-local-map) (when timeout (when set-transient-map-timer (cancel-timer set-transient-map-timer)) (setq set-transient-map-timer (run-with-idle-timer timeout nil exitfun))) (when message (message "%s" message)) exitfun)) ;;;; Defined in simple.el (compat-defun use-region-noncontiguous-p () ;; "Return non-nil for a non-contiguous region if `use-region-p'." (and (use-region-p) (region-noncontiguous-p))) (compat-defun use-region-beginning () ;; "Return the start of the region if `use-region-p'." (and (use-region-p) (region-beginning))) (compat-defun use-region-end () ;; "Return the end of the region if `use-region-p'." (and (use-region-p) (region-end))) (compat-defun get-scratch-buffer-create () ;; "Return the *scratch* buffer, creating a new one if needed." (or (get-buffer "*scratch*") (let ((scratch (get-buffer-create "*scratch*"))) ;; Don't touch the buffer contents or mode unless we know that ;; we just created it. (with-current-buffer scratch (when initial-scratch-message (insert (substitute-command-keys initial-scratch-message)) (set-buffer-modified-p nil)) (funcall initial-major-mode)) scratch))) ;;;; Defined in subr-x.el (compat-defmacro with-buffer-unmodified-if-unchanged (&rest body) ;; "Like `progn', but change buffer-modified status only if buffer text changes. If the buffer was unmodified before execution of BODY, and buffer text after execution of BODY is identical to what it was before, ensure that buffer is still marked unmodified afterwards. For example, the following won't change the buffer's modification status: (with-buffer-unmodified-if-unchanged (insert \"a\") (delete-char -1)) Note that only changes in the raw byte sequence of the buffer text, as stored in the internal representation, are monitored for the purpose of detecting the lack of changes in buffer text. Any other changes that are normally perceived as \"buffer modifications\", such as changes in text properties, `buffer-file-coding-system', buffer multibyteness, etc. -- will not be noticed, and the buffer will still be marked unmodified, effectively ignoring those changes." (declare (debug t) (indent 0)) (let ((hash (gensym)) (buffer (gensym))) `(let ((,hash (and (not (buffer-modified-p)) (buffer-hash))) (,buffer (current-buffer))) (prog1 (progn ,@body) ;; If we didn't change anything in the buffer (and the buffer ;; was previously unmodified), then flip the modification status ;; back to "unchanged". (when (and ,hash (buffer-live-p ,buffer)) (with-current-buffer ,buffer (when (and (buffer-modified-p) (equal ,hash (buffer-hash))) (restore-buffer-modified-p nil)))))))) (compat-defun add-display-text-property (start end prop value ;; &optional object) "Add display property PROP with VALUE to the text from START to END. If any text in the region has a non-nil `display' property, those properties are retained. If OBJECT is non-nil, it should be a string or a buffer. If nil, this defaults to the current buffer." (let ((sub-start start) (sub-end 0) disp) (while (< sub-end end) (setq sub-end (next-single-property-change sub-start 'display object (if (stringp object) (min (length object) end) (min end (point-max))))) (if (not (setq disp (get-text-property sub-start 'display object))) ;; No old properties in this range. (put-text-property sub-start sub-end 'display (list prop value) object) ;; We have old properties. (let ((vector nil)) ;; Make disp into a list. (setq disp (cond ((vectorp disp) (setq vector t) (append disp nil)) ((not (consp (car disp))) (list disp)) (t disp))) ;; Remove any old instances. (when-let ((old (assoc prop disp))) (setq disp (delete old disp))) (setq disp (cons (list prop value) disp)) (when vector (setq disp (vconcat disp))) ;; Finally update the range. (put-text-property sub-start sub-end 'display disp object))) (setq sub-start sub-end)))) (compat-defmacro while-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 bindings are non-nil, eval BODY and repeat. The variable list SPEC is the same as in `if-let*'." (declare (indent 1) (debug if-let)) (let ((done (gensym "done"))) `(catch ',done (while t (if-let* ,spec (progn ,@body) (throw ',done nil)))))) ;;;; Defined in files.el (compat-defun directory-abbrev-make-regexp (directory) ;; "Create a regexp to match DIRECTORY for `directory-abbrev-alist'." (let ((regexp ;; We include a slash at the end, to avoid spurious ;; matches such as `/usr/foobar' when the home dir is ;; `/usr/foo'. (concat "\\`" (regexp-quote directory) "\\(/\\|\\'\\)"))) ;; The value of regexp could be multibyte or unibyte. In the ;; latter case, we need to decode it. (if (multibyte-string-p regexp) regexp (decode-coding-string regexp (if (eq system-type 'windows-nt) 'utf-8 locale-coding-system))))) (compat-defun directory-abbrev-apply (filename) ;; "Apply the abbreviations in `directory-abbrev-alist' to FILENAME. Note that when calling this, you should set `case-fold-search' as appropriate for the filesystem used for FILENAME." (dolist (dir-abbrev directory-abbrev-alist filename) (when (string-match (car dir-abbrev) filename) (setq filename (concat (cdr dir-abbrev) (substring filename (match-end 0))))))) (compat-defun file-name-split (filename) ;; "Return a list of all the components of FILENAME. On most systems, this will be true: (equal (string-join (file-name-split filename) \"/\") filename)" (let ((components nil)) ;; If this is a directory file name, then we have a null file name ;; at the end. (when (directory-name-p filename) (push "" components) (setq filename (directory-file-name filename))) ;; Loop, chopping off components. (while (length> filename 0) (push (file-name-nondirectory filename) components) (let ((dir (file-name-directory filename))) (setq filename (and dir (directory-file-name dir))) ;; If there's nothing left to peel off, we're at the root and ;; we can stop. (when (and dir (equal dir filename)) (push (if (equal dir "") "" ;; On Windows, the first component might be "c:" or ;; the like. (substring dir 0 -1)) components) (setq filename nil)))) components)) (compat-defun file-attribute-file-identifier (attributes) ;; "The inode and device numbers in ATTRIBUTES returned by `file-attributes'. The value is a list of the form (INODENUM DEVICE), where DEVICE could be either a single number or a cons cell of two numbers. This tuple of numbers uniquely identifies the file." (nthcdr 10 attributes)) (compat-defun file-name-parent-directory (filename) ;; "Return the directory name of the parent directory of FILENAME. If FILENAME is at the root of the filesystem, return nil. If FILENAME is relative, it is interpreted to be relative to `default-directory', and the result will also be relative." (let* ((expanded-filename (expand-file-name filename)) (parent (file-name-directory (directory-file-name expanded-filename)))) (cond ;; filename is at top-level, therefore no parent ((or (null parent) ;; `equal' is enough, we don't need to resolve symlinks here ;; with `file-equal-p', also for performance (equal parent expanded-filename)) nil) ;; filename is relative, return relative parent ((not (file-name-absolute-p filename)) (file-relative-name parent)) (t parent)))) (compat-defvar file-has-changed-p--hash-table ;; (make-hash-table :test #'equal) "Internal variable used by `file-has-changed-p'.") (compat-defun file-has-changed-p (file &optional tag) ;; "Return non-nil if FILE has changed. The size and modification time of FILE are compared to the size and modification time of the same FILE during a previous invocation of `file-has-changed-p'. Thus, the first invocation of `file-has-changed-p' always returns non-nil when FILE exists. The optional argument TAG, which must be a symbol, can be used to limit the comparison to invocations with identical tags; it can be the symbol of the calling function, for example." (let* ((file (directory-file-name (expand-file-name file))) (remote-file-name-inhibit-cache t) (fileattr (file-attributes file 'integer)) (attr (and fileattr (cons (file-attribute-size fileattr) (file-attribute-modification-time fileattr)))) (sym (concat (symbol-name tag) "@" file)) (cachedattr (gethash sym file-has-changed-p--hash-table))) (unless (equal attr cachedattr) (puthash sym attr file-has-changed-p--hash-table)))) ;;;; Defined in keymap.el (compat-defun key-valid-p (keys) ;; "Say whether KEYS is a valid key. A key is a string consisting of one or more key strokes. The key strokes are separated by single space characters. 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-\" (the key named \"left\" with the hyper modifier) \"M-RET\" (the \"return\" key with a meta modifier) \"C-M-\" (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)) (let ((case-fold-search nil)) (and (stringp keys) (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) (save-match-data (catch 'exit (let ((prefixes "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?")) (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 . (= (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)))))) (compat-defun keymap--check (key) ;; "Signal an error if KEY doesn't have a valid syntax." (unless (key-valid-p key) (error "%S is not a valid key definition; see `key-valid-p'" key))) (compat-defun key-parse (keys) ;; "Convert KEYS to the internal Emacs key representation. See `kbd' for a descripion of KEYS." (declare (pure t) (side-effect-free t)) ;; A pure function is expected to preserve the match data. (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 "". (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-\0) (?C . ?\C-\0) (?H . ?\H-\0) (?M . ?\M-\0) (?s . ?\s-\0) (?S . ?\S-\0)))))) (setq prefix (+ prefix 2)) (setq word (substring word 2))) (when (string-match "^\\^.$" word) (setq bits (+ bits ?\C-\0)) (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-\0) (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) 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-\0) (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)))))) res))) (compat-defun keymap-set (keymap key definition) ;; "Set KEY to DEFINITION in KEYMAP. KEY is a string that satisfies `key-valid-p'. DEFINITION is anything that can be a key's definition: nil (means key is undefined in this keymap), a command (a Lisp function suitable for interactive calling), a string (treated as a keyboard macro), a keymap (to define a prefix key), a symbol (when the key is looked up, the symbol will stand for its function definition, which should at that time be one of the above, or another symbol whose function definition is used, etc.), a cons (STRING . DEFN), meaning that DEFN is the definition (DEFN should be a valid definition in its own right) and STRING is the menu item name (which is used only if the containing keymap has been created with a menu name, see `make-keymap'), or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP, or an extended menu item definition. (See info node `(elisp)Extended Menu Items'.)" (keymap--check key) (when (stringp definition) (keymap--check definition) (setq definition (key-parse definition))) (define-key keymap (key-parse key) definition)) (compat-defun keymap-unset (keymap key &optional remove) ;; "Remove key sequence KEY from KEYMAP. KEY is a string that satisfies `key-valid-p'. If REMOVE, remove the binding instead of unsetting it. This only makes a difference when there's a parent keymap. When unsetting a key in a child map, it will still shadow the same key in the parent keymap. Removing the binding will allow the key in the parent keymap to be used." (keymap--check key) (compat--define-key keymap (key-parse key) nil remove)) (compat-defun keymap-global-set (key command) ;; "Give KEY a global binding as COMMAND. COMMAND is the command definition to use; usually it is a symbol naming an interactively-callable function. KEY is a string that satisfies `key-valid-p'. Note that if KEY has a local binding in the current buffer, that local binding will continue to shadow any global binding that you make with this function. NOTE: The compatibility version is not a command." (keymap-set (current-global-map) key command)) (compat-defun keymap-local-set (key command) ;; "Give KEY a local binding as COMMAND. COMMAND is the command definition to use; usually it is a symbol naming an interactively-callable function. KEY is a string that satisfies `key-valid-p'. The binding goes in the current buffer's local map, which in most cases is shared with all other buffers in the same major mode. NOTE: The compatibility version is not a command." (let ((map (current-local-map))) (unless map (use-local-map (setq map (make-sparse-keymap)))) (keymap-set map key command))) (compat-defun keymap-global-unset (key &optional remove) ;; "Remove global binding of KEY (if any). KEY is a string that satisfies `key-valid-p'. If REMOVE (interactively, the prefix arg), remove the binding instead of unsetting it. See `keymap-unset' for details. NOTE: The compatibility version is not a command." (keymap-unset (current-global-map) key remove)) (compat-defun keymap-local-unset (key &optional remove) ;; "Remove local binding of KEY (if any). KEY is a string that satisfies `key-valid-p'. If REMOVE (interactively, the prefix arg), remove the binding instead of unsetting it. See `keymap-unset' for details. NOTE: The compatibility version is not a command." (when (current-local-map) (keymap-unset (current-local-map) key remove))) (compat-defun keymap-substitute (keymap olddef newdef &optional oldmap prefix) ;; "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. 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. If you don't specify OLDMAP, you can usually get the same results in a cleaner way with command remapping, like this: (define-key KEYMAP [remap OLDDEF] NEWDEF) \n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" ;; Don't document PREFIX in the doc string because we don't want to ;; advertise it. It's meant for recursive calls only. Here's its ;; meaning ;; If optional argument PREFIX is specified, it should be a key ;; prefix, a string. Redefined bindings will then be bound to the ;; original key, with PREFIX added at the front. (unless prefix (setq prefix "")) (let* ((scan (or oldmap keymap)) (prefix1 (vconcat prefix [nil])) (key-substitution-in-progress (cons scan key-substitution-in-progress))) ;; Scan OLDMAP, finding each char or event-symbol that ;; has any definition, and act on it with hack-key. (map-keymap (lambda (char defn) (aset prefix1 (length prefix) char) (substitute-key-definition-key defn olddef newdef prefix1 keymap)) scan))) (compat-defun keymap-set-after (keymap key definition &optional after) ;; "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. This is like `keymap-set' 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 \(like DEFINITION). If AFTER is t or omitted, the new binding goes at the end of the keymap. AFTER should be a single event type--a symbol or a character, not a sequence. 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." (keymap--check key) (when (eq after t) (setq after nil)) ; nil and t are treated the same (when (stringp after) (keymap--check after) (setq after (key-parse after))) ;; If we're binding this key to another key, then parse that other ;; key, too. (when (stringp definition) (keymap--check definition) (setq definition (key-parse definition))) (define-key-after keymap (key-parse key) definition after)) (compat-defun keymap-lookup ;; (keymap key &optional accept-default no-remap position) "Return the binding for command KEY. KEY is a string that satisfies `key-valid-p'. If KEYMAP is nil, look up in the current keymaps. If non-nil, it should either be a keymap or a list of keymaps, and only these keymap(s) will be consulted. The binding is probably a symbol with a function definition. Normally, `keymap-lookup' ignores bindings for t, which act as default bindings, used when nothing else in the keymap applies; this makes it usable as a general function for probing keymaps. However, if the optional second argument ACCEPT-DEFAULT is non-nil, `keymap-lookup' does recognize the default bindings, just as `read-key-sequence' does. Like the normal command loop, `keymap-lookup' will remap the command resulting from looking up KEY by looking up the command in the current keymaps. However, if the optional third argument NO-REMAP is non-nil, `keymap-lookup' returns the unmapped command. If KEY is a key sequence initiated with the mouse, the used keymaps will depend on the clicked mouse position with regard to the buffer and possible local keymaps on strings. If the optional argument POSITION is non-nil, it specifies a mouse position as returned by `event-start' and `event-end', and the lookup occurs in the keymaps associated with it instead of KEY. It can also be a number or marker, in which case the keymap properties at the specified buffer position instead of point are used." (keymap--check key) (when (and keymap position) (error "Can't pass in both keymap and position")) (if keymap (let ((value (lookup-key keymap (key-parse key) accept-default))) (if (and (not no-remap) (symbolp value)) (or (command-remapping value) value) value)) (key-binding (key-parse key) accept-default no-remap position))) (compat-defun keymap-local-lookup (keys &optional accept-default) ;; "Return the binding for command KEYS in current local keymap only. KEY is a string that satisfies `key-valid-p'. The binding is probably a symbol with a function definition. If optional argument ACCEPT-DEFAULT is non-nil, recognize default bindings; see the description of `keymap-lookup' for more details about this." (when-let ((map (current-local-map))) (keymap-lookup map keys accept-default))) (compat-defun keymap-global-lookup (keys &optional accept-default _message) ;; "Return the binding for command KEYS in current global keymap only. KEY is a string that satisfies `key-valid-p'. The binding is probably a symbol with a function definition. This function's return values are the same as those of `keymap-lookup' \(which see). If optional argument ACCEPT-DEFAULT is non-nil, recognize default bindings; see the description of `keymap-lookup' for more details about this. NOTE: The compatibility version is not a command." (keymap-lookup (current-global-map) keys accept-default)) (compat-defun define-keymap (&rest definitions) ;; "Create a new keymap and define KEY/DEFINITION pairs as key bindings. The new keymap is returned. Options can be given as keywords before the KEY/DEFINITION 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 `keymap-set'. 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)) (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)))) seen-keys) (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) (if (member key seen-keys) (error "Duplicate definition for key: %S %s" key keymap) (push key seen-keys)) (keymap-set keymap key def))))) keymap))) (compat-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. The `:repeat' keyword can also be specified; it controls the `repeat-mode' behavior of the bindings in the keymap. When it is non-nil, all commands in the map will have the `repeat-map' symbol property. More control is available over which commands are repeatable; the value can also be a property list with properties `:enter' and `:exit', for example: :repeat (:enter (commands ...) :exit (commands ...)) `:enter' specifies the list of additional commands that only enter `repeat-mode'. When the list is empty, then only the commands defined in the map enter `repeat-mode'. Specifying a list of commands is useful when there are commands that have the `repeat-map' symbol property, but don't exist in this specific map. `:exit' is a list of commands that exit `repeat-mode'. When the list is empty, no commands in the map exit `repeat-mode'. Specifying a list of commands is useful when those commands exist in this specific map, but should not have the `repeat-map' symbol property. \(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP REPEAT &rest [KEY DEFINITION]...)" (declare (indent 1)) (let ((opts nil) doc repeat props) (while (and defs (keywordp (car defs)) (not (eq (car defs) :menu))) (let ((keyword (pop defs))) (unless defs (error "Uneven number of keywords")) (cond ((eq keyword :doc) (setq doc (pop defs))) ((eq keyword :repeat) (setq repeat (pop defs))) (t (push keyword opts) (push (pop defs) opts))))) (unless (zerop (% (length defs) 2)) (error "Uneven number of key/definition pairs: %s" defs)) (let ((defs defs) key seen-keys) (while defs (setq key (pop defs)) (pop defs) (unless (eq key :menu) (if (member key seen-keys) (error "Duplicate definition for key '%s' in keymap '%s'" key variable-name) (push key seen-keys))))) (when repeat (let ((defs defs) def) (dolist (def (plist-get repeat :enter)) (push `(put ',def 'repeat-map ',variable-name) props)) (while defs (pop defs) (setq def (pop defs)) (when (and (memq (car def) '(function quote)) (not (memq (cadr def) (plist-get repeat :exit)))) (push `(put ,def 'repeat-map ',variable-name) props))))) (let ((defvar-form `(defvar ,variable-name (define-keymap ,@(nreverse opts) ,@defs) ,@(and doc (list doc))))) (if props `(progn ,defvar-form ,@(nreverse props)) defvar-form)))) ;;;; Defined in keymap.c (compat-defun define-key (keymap key def &optional remove) ;; "Handle optional argument REMOVE." :extended t (if (not remove) (define-key keymap key def) ;; Canonicalize key (setq key (key-parse (key-description key))) (define-key keymap key nil) ;; Split M-key in ESC key (setq key (mapcan (lambda (k) (if (and (integerp k) (/= (logand k ?\M-\0) 0)) (list ?\e (logxor k ?\M-\0)) (list k))) key)) ;; Delete single keys directly (if (length= key 1) (delete key keymap) ;; Lookup submap and delete key from there (let ((submap (lookup-key keymap (vconcat (butlast key))))) (unless (keymapp submap) (error "Not a keymap for %s" key)) (when (symbolp submap) (setq submap (symbol-function submap))) (delete (last key) submap))) def)) ;;;; Defined in help.el (compat-defun substitute-quotes (string) ;; "Substitute quote characters for display. Each grave accent \\=` is replaced by left quote, and each apostrophe \\=' is replaced by right quote. Left and right quote characters are specified by `text-quoting-style'." (cond ((eq (text-quoting-style) 'curve) (string-replace "`" "‘" (string-replace "'" "’" string))) ((eq (text-quoting-style) 'straight) (string-replace "`" "'" string)) (t string))) ;;;; Defined in button.el (compat-defun button--properties (callback data help-echo) ;; "Helper function." (list 'font-lock-face 'button 'mouse-face 'highlight 'help-echo help-echo 'button t 'follow-link t 'category t 'button-data data 'keymap button-map 'action callback)) (compat-defun buttonize (string callback &optional data help-echo) ;; "Make STRING into a button and return it. When clicked, CALLBACK will be called with the DATA as the function argument. If DATA isn't present (or is nil), the button itself will be used instead as the function argument. If HELP-ECHO, use that as the `help-echo' property. Also see `buttonize-region'." (let ((string (apply #'propertize string (button--properties callback data help-echo)))) ;; Add the face to the end so that it can be overridden. (add-face-text-property 0 (length string) 'button t string) string)) (compat-defun buttonize-region (start end callback &optional data help-echo) ;; "Make the region between START and END into a button. When clicked, CALLBACK will be called with the DATA as the function argument. If DATA isn't present (or is nil), the button itself will be used instead as the function argument. If HELP-ECHO, use that as the `help-echo' property. Also see `buttonize'." (add-text-properties start end (button--properties callback data help-echo)) (add-face-text-property start end 'button t)) ;;;; Defined in rmc.el (compat-defun read-multiple-choice ;; (prompt choices &optional _help-str _show-help long-form) "Handle LONG-FORM argument." :extended t (if (not long-form) (read-multiple-choice prompt choices) (let ((answer (completing-read (concat prompt " (" (mapconcat #'identity (mapcar #'cadr choices) "/") ") ") (mapcar #'cadr choices) nil t))) (catch 'found (dolist (c choices) (when (equal answer (cadr c)) (throw 'found c))))))) ;;;; Defined in paragraphs.el (compat-defun count-sentences (start end) ;; "Count sentences in current buffer from START to END." (let ((sentences 0) (inhibit-field-text-motion t)) (save-excursion (save-restriction (narrow-to-region start end) (goto-char (point-min)) (while (ignore-errors (forward-sentence)) (setq sentences (1+ sentences))) (when (/= (skip-chars-backward " \t\n") 0) (setq sentences (1- sentences))) sentences)))) ;;;; Defined in cl-lib.el (compat-defun cl-constantly (value) ;; "Return a function that takes any number of arguments, but returns VALUE." :feature cl-lib (lambda (&rest _) value)) ;;;; Defined in cl-macs.el (compat-defmacro cl-with-gensyms (names &rest body) ;; "Bind each of NAMES to an uninterned symbol and evaluate BODY." ;; No :feature since macro is autoloaded (declare (debug (sexp body)) (indent 1)) `(let ,(cl-loop for name in names collect `(,name (gensym (symbol-name ',name)))) ,@body)) (compat-defmacro cl-once-only (names &rest body) ;; "Generate code to evaluate each of NAMES just once in BODY. This macro helps with writing other macros. Each of names is either (NAME FORM) or NAME, which latter means (NAME NAME). During macroexpansion, each NAME is bound to an uninterned symbol. The expansion evaluates each FORM and binds it to the corresponding uninterned symbol. For example, consider this macro: (defmacro my-cons (x) (cl-once-only (x) \\=`(cons ,x ,x))) The call (my-cons (pop y)) will expand to something like this: (let ((g1 (pop y))) (cons g1 g1)) The use of `cl-once-only' ensures that the pop is performed only once, as intended. See also `macroexp-let2'." ;; No :feature since macro is autoloaded (declare (debug (sexp body)) (indent 1)) (setq names (mapcar #'ensure-list names)) (let ((our-gensyms (cl-loop for _ in names collect (gensym)))) `(let ,(cl-loop for sym in our-gensyms collect `(,sym (gensym))) `(let ,(list ,@(cl-loop for name in names for gensym in our-gensyms for to-eval = (or (cadr name) (car name)) collect ``(,,gensym ,,to-eval))) ,(let ,(cl-loop for name in names for gensym in our-gensyms collect `(,(car name) ,gensym)) ,@body))))) ;;;; Defined in ert-x.el (compat-defmacro ert-with-temp-file (name &rest body) ;; "Bind NAME to the name of a new temporary file and evaluate BODY. Delete the temporary file after BODY exits normally or non-locally. NAME will be bound to the file name of the temporary file. The following keyword arguments are supported: :prefix STRING If non-nil, pass STRING to `make-temp-file' as the PREFIX argument. Otherwise, use the value of `ert-temp-file-prefix'. :suffix STRING If non-nil, pass STRING to `make-temp-file' as the SUFFIX argument. Otherwise, use the value of `ert-temp-file-suffix'; if the value of that variable is nil, generate a suffix based on the name of the file that `ert-with-temp-file' is called from. :text STRING If non-nil, pass STRING to `make-temp-file' as the TEXT argument. :buffer SYMBOL Open the temporary file using `find-file-noselect' and bind SYMBOL to the buffer. Kill the buffer after BODY exits normally or non-locally. :coding CODING If non-nil, bind `coding-system-for-write' to CODING when executing BODY. This is handy when STRING includes non-ASCII characters or the temporary file must have a specific encoding or end-of-line format. See also `ert-with-temp-directory'." :feature ert-x (declare (indent 1) (debug (symbolp body))) (cl-check-type name symbol) (let (keyw prefix suffix directory text extra-keywords buffer coding) (while (keywordp (setq keyw (car body))) (setq body (cdr body)) (pcase keyw (:prefix (setq prefix (pop body))) (:suffix (setq suffix (pop body))) ;; This is only for internal use by `ert-with-temp-directory' ;; and is therefore not documented. (:directory (setq directory (pop body))) (:text (setq text (pop body))) (:buffer (setq buffer (pop body))) (:coding (setq coding (pop body))) (_ (push keyw extra-keywords) (pop body)))) (when extra-keywords (error "Invalid keywords: %s" (mapconcat #'symbol-name extra-keywords " "))) (let ((temp-file (make-symbol "temp-file")) (prefix (or prefix "emacs-test-")) (suffix (or suffix (thread-last (file-name-base (or (macroexp-file-name) buffer-file-name)) (replace-regexp-in-string (rx string-start (group (+? not-newline)) (regexp "-?tests?") string-end) "\\1") (concat "-"))))) `(let* ((coding-system-for-write ,(or coding coding-system-for-write)) (,temp-file (,(if directory 'file-name-as-directory 'identity) (,(if (fboundp 'compat--make-temp-file) 'compat--make-temp-file 'make-temp-file) ,prefix ,directory ,suffix ,text))) (,name ,(if directory `(file-name-as-directory ,temp-file) temp-file)) ,@(when buffer (list `(,buffer (find-file-literally ,temp-file))))) (unwind-protect (progn ,@body) (ignore-errors ,@(when buffer (list `(with-current-buffer ,buffer (set-buffer-modified-p nil)) `(kill-buffer ,buffer)))) (ignore-errors ,(if directory `(delete-directory ,temp-file :recursive) `(delete-file ,temp-file)))))))) (compat-defmacro ert-with-temp-directory (name &rest body) ;; "Bind NAME to the name of a new temporary directory and evaluate BODY. Delete the temporary directory after BODY exits normally or non-locally. NAME is bound to the directory name, not the directory file name. (In other words, it will end with the directory delimiter; on Unix-like systems, it will end with \"/\".) The same keyword arguments are supported as in `ert-with-temp-file' (which see), except for :text." :feature ert-x (declare (indent 1) (debug (symbolp body))) (let ((tail body) keyw) (while (keywordp (setq keyw (car tail))) (setq tail (cddr tail)) (pcase keyw (:text (error "Invalid keyword for directory: :text"))))) `(ert-with-temp-file ,name :directory t ,@body)) ;;;; Defined in wid-edit.el (compat-guard (not (fboundp 'widget-key-validate)) ;; :feature wid-edit (defvar widget-key-prompt-value-history nil "History of input to `widget-key-prompt-value'.") (define-widget 'key 'editable-field "A key sequence." :prompt-value 'widget-field-prompt-value :match 'widget-key-valid-p :format "%{%t%}: %v" :validate 'widget-key-validate :keymap widget-key-sequence-map :help-echo "C-q: insert KEY, EVENT, or CODE; RET: enter value" :tag "Key") (defun widget-key-valid-p (_widget value) (key-valid-p value)) (defun widget-key-validate (widget) (unless (and (stringp (widget-value widget)) (key-valid-p (widget-value widget))) (widget-put widget :error (format "Invalid key: %S" (widget-value widget))) widget))) (provide 'compat-29) ;;; compat-29.el ends here