daniel/emacs
1
2
Fork 0
Code Issues 7 Pull Requests Projects Releases Wiki Activity

pkg update and first config fix

Browse Source 
org-brain not working, add org-roam
This commit is contained in:
Daniel Weschke
2022-12-19 23:02:34 +01:00
parent 02b3e07185
commit 82f05baffe
885 changed files with 356098 additions and 36993 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
lisp/compat/.dir-locals.el Normal file
View File

@@ -0,0 +1,7 @@
;;; Directory Local Variables
;;; For more information see (info "(emacs) Directory Variables")
((emacs-lisp-mode
(byte-compile-docstring-max-column . 100)
(show-trailing-whitespace . t)
(indent-tabs-mode . nil)))

108
lisp/compat/NEWS.org Normal file
View File

@@ -0,0 +1,108 @@
#+options: toc:nil num:nil
#+link: compat https://todo.sr.ht/~pkal/compat/
* Release of "Compat" Version 28.1.2.2
This is a minor release that hopes to address [[compat:7]].
(Release <2022-08-25 Thu>)
* Release of "Compat" Version 28.1.2.1
This is a minor release adding the following changes:
- Add =derived-mode-p= defined in Emacs 27
- Add =provided-mode-derived-p= defined in Emacs 27
- Add =read-multiple-choice= defined in Emacs 26
- Add =file-name-absolute-p= defined in Emacs 28
The only other notable change is that the manual has been rewritten to
include much more documentation that had been the case previously.
(Release <2022-08-24 Wed>)
* Release of "Compat" Version 28.1.2.0
The main change of this release has been the major simplification of
Compat's initialisation system, improving the situation around issues
people had been reporting ([[compat:4]], once again) with unconventional
or unpopular packaging systems.
In addition to this, the following functional changes have been made:
- Fix =format-prompt= of an empty string as "default" argument
- Add =decoded-time-period= defined in Emacs 28
- Add =subr-primitive-p= defined in Emacs 28
Minor improvements to manual are also part of this release.
(Release <2022-07-18 Mon>)
* Release of "Compat" Version 28.1.1.3
This release just contains a hot-fix for an issue introduced in the
last version, where compat.el raises an error during byte compilation.
See [[compat:4]].
(Release <2022-06-19 Sun>)
* Release of "Compat" Version 28.1.1.2
Two main changes have necessitated a new patch release:
1. Fix issues related to the loading of compat when uncompiled. See
[[https://lists.sr.ht/~pkal/compat-devel/%3C20220530191000.2183047-1-jonas%40bernoul.li%3E][this thread]] for more details on the problem.
2. Fix issues related to the loading of compat on old pre-releases
(think of 28.0.50). See [[https://lists.sr.ht/~pkal/compat-devel/%3Cf8635d7d-e233-448f-b325-9e850363241c%40www.fastmail.com%3E][this thread]] for more details on the
problem.
(Released <2022-06-22 Wed>)
* Release of "Compat" Version 28.1.1.1
This is a minor release fixing a bug in =json-serialize=, that could
cause unintended side-effects, not related to packages using Compat
directly (see [[compat:2]]).
(Released <2022-05-05 Thu>)
* Release of "Compat" Version 28.1.1.0
This release mostly fixes a number of smaller bugs that were not
identified as of 28.1.0.0. Nevertheless these warrent a version bump,
as some of these changes a functional. These include:
- The addition of the =file-attribute-*= accessor functions.
- The addition of =file-attribute-collect=.
- Improvements to the Texinfo manual (via Jonas Bernoulli's recent
work on =ox-texinfo=). For the time being, the Texinfo file is
maintained in the repository itself, next to the =MANUAL= file.
This might change in the future.
- Adding a prefix to =string-trim=, =string-trim-left= and
=string-trim-right= (i.e. now =compat-string-trim=,
=compat-string-trim-left= and =compat-string-trim-right=)
- Improving the version inference used in the =compat-*= macros.
This improves the compile-time optimisation that strips away
functions that are known to be defined for a specific version.
- The addition of generalised variable (=setf=) support for
=compat-alist-get=.
- The addition of =image-property= and generalised variable support
for =image-property=.
- The addition of the function =compat-executable-find=.
- The addition of the function =compat-dired-get-marked-files=.
- The addition of the function =exec-path=.
- The addition of the function =make-lock-file-name=.
- The addition of the function =null-device=.
- The addition of the function =time-equal-p=.
- The addition of the function =date-days-in-month=.
- Handling out-of-directory byte compilation better.
- Fixing the usage and edge-cases of =and-let*=.
Furthermore a bug tracker was added: https://todo.sr.ht/~pkal/compat,
which is the preferred way to report issues or feature requests.
General problems, questions, etc. are still better discussed on the
development mailing list: https://lists.sr.ht/~pkal/compat-devel.
(Released <2022-04-22 Fri>)

495
lisp/compat/compat-24.el Normal file
View File

@@ -0,0 +1,495 @@
;;; compat-24.el --- Compatibility Layer for Emacs 24.4 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Find here the functionality added in Emacs 24.4, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `compat-='
;; - `compat-<'
;; - `compat->'
;; - `compat-<='
;; - `compat->='
;; - `split-string'.
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "24.4")
;;;; Defined in data.c
(compat-defun = (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (= number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun < (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (< number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun > (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (> number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun <= (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (<= number-or-marker (car numbers-or-markers))
(throw 'fail nil))
(setq number-or-marker (pop numbers-or-markers)))
t))
(compat-defun >= (number-or-marker &rest numbers-or-markers)
"Handle multiple arguments."
:prefix t
(catch 'fail
(while numbers-or-markers
(unless (>= number-or-marker (pop numbers-or-markers))
(throw 'fail nil)))
t))
(compat-defun bool-vector-exclusive-or (a b &optional c)
"Return A ^ B, bitwise exclusive or.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (not (eq (aref a i) (aref b i)))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-union (a b &optional c)
"Return A | B, bitwise or.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (or (aref a i) (aref b i))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-intersection (a b &optional c)
"Return A & B, bitwise and.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (and (aref a i) (aref b i))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-set-difference (a b &optional c)
"Return A &~ B, set difference.
If optional third argument C is given, store result into C.
A, B, and C must be bool vectors of the same length.
Return the destination vector if it changed or nil otherwise."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(unless (or (null c) (bool-vector-p c))
(signal 'wrong-type-argument (list 'bool-vector-p c)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(let ((val (and (aref a i) (not (aref b i)))))
(unless (eq val (aref dest i))
(setq changed t))
(aset dest i val)))
(if c (and changed c) dest)))
(compat-defun bool-vector-not (a &optional b)
"Compute ~A, set complement.
If optional second argument B is given, store result into B.
A and B must be bool vectors of the same length.
Return the destination vector."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (or (null b) (bool-vector-p b))
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(let ((dest (or b (make-bool-vector (length a) nil))))
(when (/= (length a) (length dest))
(signal 'wrong-length-argument (list (length a) (length dest))))
(dotimes (i (length dest))
(aset dest i (not (aref a i))))
dest))
(compat-defun bool-vector-subsetp (a b)
"Return t if every t value in A is also t in B, nil otherwise.
A and B must be bool vectors of the same length."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(unless (bool-vector-p b)
(signal 'wrong-type-argument (list 'bool-vector-p b)))
(when (/= (length a) (length b))
(signal 'wrong-length-argument (list (length a) (length b))))
(catch 'not-subset
(dotimes (i (length a))
(when (if (aref a i) (not (aref b i)) nil)
(throw 'not-subset nil)))
t))
(compat-defun bool-vector-count-consecutive (a b i)
"Count how many consecutive elements in A equal B starting at I.
A is a bool vector, B is t or nil, and I is an index into A."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(setq b (and b t)) ;normalise to nil or t
(unless (< i (length a))
(signal 'args-out-of-range (list a i)))
(let ((len (length a)) (n i))
(while (and (< i len) (eq (aref a i) b))
(setq i (1+ i)))
(- i n)))
(compat-defun bool-vector-count-population (a)
"Count how many elements in A are t.
A is a bool vector. To count A's nil elements, subtract the
return value from A's length."
(unless (bool-vector-p a)
(signal 'wrong-type-argument (list 'bool-vector-p a)))
(let ((n 0))
(dotimes (i (length a))
(when (aref a i)
(setq n (1+ n))))
n))
;;;; Defined in subr.el
;;* UNTESTED
(compat-defmacro with-eval-after-load (file &rest body)
"Execute BODY after FILE is loaded.
FILE is normally a feature name, but it can also be a file name,
in case that file does not provide any feature. See `eval-after-load'
for more details about the different forms of FILE and their semantics."
(declare (indent 1) (debug (form def-body)))
;; See https://nullprogram.com/blog/2018/02/22/ on how
;; `eval-after-load' is used to preserve compatibility with 24.3.
`(eval-after-load ,file `(funcall ',,`(lambda () ,@body))))
(compat-defun special-form-p (object)
"Non-nil if and only if OBJECT is a special form."
(if (and (symbolp object) (fboundp object))
(setq object (condition-case nil
(indirect-function object)
(void-function nil))))
(and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
(compat-defun macrop (object)
"Non-nil if and only if OBJECT is a macro."
(let ((def (condition-case nil
(indirect-function object)
(void-function nil))))
(when (consp def)
(or (eq 'macro (car def))
(and (autoloadp def) (memq (nth 4 def) '(macro t)))))))
(compat-defun string-suffix-p (suffix string &optional ignore-case)
"Return non-nil if SUFFIX is a suffix of STRING.
If IGNORE-CASE is non-nil, the comparison is done without paying
attention to case differences."
(let ((start-pos (- (length string) (length suffix))))
(and (>= start-pos 0)
(eq t (compare-strings suffix nil nil
string start-pos nil ignore-case)))))
(compat-defun split-string (string &optional separators omit-nulls trim)
"Extend `split-string' by a TRIM argument.
The remaining arguments STRING, SEPARATORS and OMIT-NULLS are
handled just as with `split-string'."
:prefix t
(let* ((token (split-string string separators omit-nulls))
(trimmed (if trim
(mapcar
(lambda (token)
(when (string-match (concat "\\`" trim) token)
(setq token (substring token (match-end 0))))
(when (string-match (concat trim "\\'") token)
(setq token (substring token 0 (match-beginning 0))))
token)
token)
token)))
(if omit-nulls (delete "" trimmed) trimmed)))
(compat-defun delete-consecutive-dups (list &optional circular)
"Destructively remove `equal' consecutive duplicates from LIST.
First and last elements are considered consecutive if CIRCULAR is
non-nil."
(let ((tail list) last)
(while (cdr tail)
(if (equal (car tail) (cadr tail))
(setcdr tail (cddr tail))
(setq last tail
tail (cdr tail))))
(if (and circular
last
(equal (car tail) (car list)))
(setcdr last nil)))
list)
;;* UNTESTED
(compat-defun define-error (name message &optional parent)
"Define NAME as a new error signal.
MESSAGE is a string that will be output to the echo area if such an error
is signaled without being caught by a `condition-case'.
PARENT is either a signal or a list of signals from which it inherits.
Defaults to `error'."
(unless parent (setq parent 'error))
(let ((conditions
(if (consp parent)
(apply #'append
(mapcar (lambda (parent)
(cons parent
(or (get parent 'error-conditions)
(error "Unknown signal `%s'" parent))))
parent))
(cons parent (get parent 'error-conditions)))))
(put name 'error-conditions
(delete-dups (copy-sequence (cons name conditions))))
(when message (put name 'error-message message))))
;;;; Defined in minibuffer.el
;;* UNTESTED
(compat-defun completion-table-with-cache (fun &optional ignore-case)
"Create dynamic completion table from function FUN, with cache.
This is a wrapper for `completion-table-dynamic' that saves the last
argument-result pair from FUN, so that several lookups with the
same argument (or with an argument that starts with the first one)
only need to call FUN once. This can be useful when FUN performs a
relatively slow operation, such as calling an external process.
When IGNORE-CASE is non-nil, FUN is expected to be case-insensitive."
(let* (last-arg last-result
(new-fun
(lambda (arg)
(if (and last-arg (string-prefix-p last-arg arg ignore-case))
last-result
(prog1
(setq last-result (funcall fun arg))
(setq last-arg arg))))))
(completion-table-dynamic new-fun)))
;;* UNTESTED
(compat-defun completion-table-merge (&rest tables)
"Create a completion table that collects completions from all TABLES."
(lambda (string pred action)
(cond
((null action)
(let ((retvals (mapcar (lambda (table)
(try-completion string table pred))
tables)))
(if (member string retvals)
string
(try-completion string
(mapcar (lambda (value)
(if (eq value t) string value))
(delq nil retvals))
pred))))
((eq action t)
(apply #'append (mapcar (lambda (table)
(all-completions string table pred))
tables)))
(t
(completion--some (lambda (table)
(complete-with-action action table string pred))
tables)))))
;;;; Defined in subr-x.el
;;* UNTESTED
(compat-advise require (feature &rest args)
"Allow for Emacs 24.x to require the inexistent FEATURE subr-x."
;; As the compatibility advise around `require` is more a hack than
;; of of actual value, the highlighting is suppressed.
:no-highlight t
(if (eq feature 'subr-x)
(let ((entry (assq feature after-load-alist)))
(let ((load-file-name nil))
(dolist (form (cdr entry))
(funcall (eval form t)))))
(apply oldfun feature args)))
(compat-defun hash-table-keys (hash-table)
"Return a list of keys in HASH-TABLE."
(let (values)
(maphash
(lambda (k _v) (push k values))
hash-table)
values))
(compat-defun hash-table-values (hash-table)
"Return a list of values in HASH-TABLE."
(let (values)
(maphash
(lambda (_k v) (push v values))
hash-table)
values))
(compat-defun string-empty-p (string)
"Check whether STRING is empty."
(string= string ""))
(compat-defun string-join (strings &optional separator)
"Join all STRINGS using SEPARATOR.
Optional argument SEPARATOR must be a string, a vector, or a list of
characters; nil stands for the empty string."
(mapconcat #'identity strings separator))
(compat-defun string-blank-p (string)
"Check whether STRING is either empty or only whitespace.
The following characters count as whitespace here: space, tab, newline and
carriage return."
(string-match-p "\\`[ \t\n\r]*\\'" string))
(compat-defun string-remove-prefix (prefix string)
"Remove PREFIX from STRING if present."
(if (string-prefix-p prefix string)
(substring string (length prefix))
string))
(compat-defun string-remove-suffix (suffix string)
"Remove SUFFIX from STRING if present."
(if (string-suffix-p suffix string)
(substring string 0 (- (length string) (length suffix)))
string))
;;;; Defined in faces.el
;;* UNTESTED
(compat-defun face-spec-set (face spec &optional spec-type)
"Set the FACE's spec SPEC, define FACE, and recalculate its attributes.
See `defface' for the format of SPEC.
The appearance of each face is controlled by its specs (set via
this function), and by the internal frame-specific face
attributes (set via `set-face-attribute').
This function also defines FACE as a valid face name if it is not
already one, and (re)calculates its attributes on existing
frames.
The optional argument SPEC-TYPE determines which spec to set:
nil, omitted or `face-override-spec' means the override spec,
which overrides all the other types of spec mentioned below
(this is usually what you want if calling this function
outside of Custom code);
`customized-face' or `saved-face' means the customized spec or
the saved custom spec;
`face-defface-spec' means the default spec
(usually set only via `defface');
`reset' means to ignore SPEC, but clear the `customized-face'
and `face-override-spec' specs;
Any other value means not to set any spec, but to run the
function for defining FACE and recalculating its attributes."
(if (get face 'face-alias)
(setq face (get face 'face-alias)))
;; Save SPEC to the relevant symbol property.
(unless spec-type
(setq spec-type 'face-override-spec))
(if (memq spec-type '(face-defface-spec face-override-spec
customized-face saved-face))
(put face spec-type spec))
(if (memq spec-type '(reset saved-face))
(put face 'customized-face nil))
;; Setting the face spec via Custom empties out any override spec,
;; similar to how setting a variable via Custom changes its values.
(if (memq spec-type '(customized-face saved-face reset))
(put face 'face-override-spec nil))
;; If we reset the face based on its custom spec, it is unmodified
;; as far as Custom is concerned.
(unless (eq face 'face-override-spec)
(put face 'face-modified nil))
;; Initialize the face if it does not exist, then recalculate.
(make-empty-face face)
(dolist (frame (frame-list))
(face-spec-recalc face frame)))
(compat--inhibit-prefixed (provide 'compat-24))
;;; compat-24.el ends here

322
lisp/compat/compat-25.el Normal file
View File

@@ -0,0 +1,322 @@
;;; compat-25.el --- Compatibility Layer for Emacs 25.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Find here the functionality added in Emacs 25.1, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `compat-sort'
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "25.1")
;;;; Defined in alloc.c
(compat-defun bool-vector (&rest objects)
"Return a new bool-vector with specified arguments as elements.
Allows any number of arguments, including zero.
usage: (bool-vector &rest OBJECTS)"
(let ((vec (make-bool-vector (length objects) nil))
(i 0))
(while objects
(when (car objects)
(aset vec i t))
(setq objects (cdr objects)
i (1+ i)))
vec))
;;;; Defined in fns.c
(compat-defun sort (seq predicate)
"Extend `sort' to sort SEQ as a vector."
:prefix t
(cond
((listp seq)
(sort seq predicate))
((vectorp seq)
(let ((cseq (sort (append seq nil) predicate)))
(dotimes (i (length cseq))
(setf (aref seq i) (nth i cseq)))
(apply #'vector cseq)))
((signal 'wrong-type-argument 'list-or-vector-p))))
;;;; Defined in editfns.c
(compat-defun format-message (string &rest objects)
"Format a string out of a format-string and arguments.
The first argument is a format control string.
The other arguments are substituted into it to make the result, a string.
This implementation is equivalent to `format'."
(apply #'format string objects))
;;;; Defined in minibuf.c
;; TODO advise read-buffer to handle 4th argument
;;;; Defined in fileio.c
(compat-defun directory-name-p (name)
"Return non-nil if NAME ends with a directory separator character."
:realname compat--directory-name-p
(eq (eval-when-compile
(if (memq system-type '(cygwin windows-nt ms-dos))
?\\ ?/))
(aref name (1- (length name)))))
;;;; Defined in subr.el
(compat-defun string-greaterp (string1 string2)
"Return non-nil if STRING1 is greater than STRING2 in lexicographic order.
Case is significant.
Symbols are also allowed; their print names are used instead."
(string-lessp string2 string1))
;;* UNTESTED
(compat-defmacro with-file-modes (modes &rest body)
"Execute BODY with default file permissions temporarily set to MODES.
MODES is as for `set-default-file-modes'."
(declare (indent 1) (debug t))
(let ((umask (make-symbol "umask")))
`(let ((,umask (default-file-modes)))
(unwind-protect
(progn
(set-default-file-modes ,modes)
,@body)
(set-default-file-modes ,umask)))))
(compat-defun alist-get (key alist &optional default remove testfn)
"Find the first element of ALIST whose `car' equals KEY and return its `cdr'.
If KEY is not found in ALIST, return DEFAULT.
Equality with KEY is tested by TESTFN, defaulting to `eq'."
:realname compat--alist-get-full-elisp
(ignore remove)
(let (entry)
(cond
((or (null testfn) (eq testfn 'eq))
(setq entry (assq key alist)))
((eq testfn 'equal)
(setq entry (assoc key alist)))
((catch 'found
(dolist (ent alist)
(when (and (consp ent) (funcall testfn (car ent) key))
(throw 'found (setq entry ent))))
default)))
(if entry (cdr entry) default)))
;;;; Defined in subr-x.el
(compat-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."
:realname compat--if-let
:feature 'subr-x
(declare (indent 2)
(debug ([&or (symbolp form)
(&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)))
`(compat--if-let* ,spec ,then ,(macroexp-progn else)))
(compat-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'."
:feature 'subr-x
(declare (indent 1) (debug if-let))
`(compat--if-let ,spec ,(macroexp-progn body)))
(compat-defmacro thread-first (&rest forms)
"Thread FORMS elements as the first argument of their successor.
Example:
(thread-first
5
(+ 20)
(/ 25)
-
(+ 40))
Is equivalent to:
(+ (- (/ (+ 5 20) 25)) 40)
Note how the single `-' got converted into a list before
threading."
:feature 'subr-x
(declare (indent 1)
(debug (form &rest [&or symbolp (sexp &rest form)])))
(let ((body (car forms)))
(dolist (form (cdr forms))
(when (symbolp form)
(setq form (list form)))
(setq body (append (list (car form))
(list body)
(cdr form))))
body))
(compat-defmacro thread-last (&rest forms)
"Thread FORMS elements as the last argument of their successor.
Example:
(thread-last
5
(+ 20)
(/ 25)
-
(+ 40))
Is equivalent to:
(+ 40 (- (/ 25 (+ 20 5))))
Note how the single `-' got converted into a list before
threading."
:feature 'subr-x
(declare (indent 1) (debug thread-first))
(let ((body (car forms)))
(dolist (form (cdr forms))
(when (symbolp form)
(setq form (list form)))
(setq body (append form (list body))))
body))
;;;; Defined in macroexp.el
(declare-function macrop nil (object))
(compat-defun macroexpand-1 (form &optional environment)
"Perform (at most) one step of macro expansion."
:feature 'macroexp
(cond
((consp form)
(let* ((head (car form))
(env-expander (assq head environment)))
(if env-expander
(if (cdr env-expander)
(apply (cdr env-expander) (cdr form))
form)
(if (not (and (symbolp head) (fboundp head)))
form
(let ((def (autoload-do-load (symbol-function head) head 'macro)))
(cond
;; Follow alias, but only for macros, otherwise we may end up
;; skipping an important compiler-macro (e.g. cl--block-wrapper).
((and (symbolp def) (macrop def)) (cons def (cdr form)))
((not (consp def)) form)
(t
(if (eq 'macro (car def))
(apply (cdr def) (cdr form))
form))))))))
(t form)))
;;;; Defined in byte-run.el
;;* UNTESTED
(compat-defun function-put (func prop value)
"Set FUNCTION's property PROP to VALUE.
The namespace for PROP is shared with symbols.
So far, FUNCTION can only be a symbol, not a lambda expression."
:version "24.4"
(put func prop value))
;;;; Defined in files.el
;;* UNTESTED
(compat-defun directory-files-recursively
(dir regexp &optional include-directories predicate follow-symlinks)
"Return list of all files under directory DIR whose names match REGEXP.
This function works recursively. Files are returned in \"depth
first\" order, and files from each directory are sorted in
alphabetical order. Each file name appears in the returned list
in its absolute form.
By default, the returned list excludes directories, but if
optional argument INCLUDE-DIRECTORIES is non-nil, they are
included.
PREDICATE can be either nil (which means that all subdirectories
of DIR are descended into), t (which means that subdirectories that
can't be read are ignored), or a function (which is called with
the name of each subdirectory, and should return non-nil if the
subdirectory is to be descended into).
If FOLLOW-SYMLINKS is non-nil, symbolic links that point to
directories are followed. Note that this can lead to infinite
recursion."
:realname compat--directory-files-recursively
(let* ((result nil)
(files nil)
(dir (directory-file-name dir))
;; When DIR is "/", remote file names like "/method:" could
;; also be offered. We shall suppress them.
(tramp-mode (and tramp-mode (file-remote-p (expand-file-name dir)))))
(dolist (file (sort (file-name-all-completions "" dir)
'string<))
(unless (member file '("./" "../"))
(if (directory-name-p file)
(let* ((leaf (substring file 0 (1- (length file))))
(full-file (concat dir "/" leaf)))
;; Don't follow symlinks to other directories.
(when (and (or (not (file-symlink-p full-file))
(and (file-symlink-p full-file)
follow-symlinks))
;; Allow filtering subdirectories.
(or (eq predicate nil)
(eq predicate t)
(funcall predicate full-file)))
(let ((sub-files
(if (eq predicate t)
(condition-case nil
(compat--directory-files-recursively
full-file regexp include-directories
predicate follow-symlinks)
(file-error nil))
(compat--directory-files-recursively
full-file regexp include-directories
predicate follow-symlinks))))
(setq result (nconc result sub-files))))
(when (and include-directories
(string-match regexp leaf))
(setq result (nconc result (list full-file)))))
(when (string-match regexp file)
(push (concat dir "/" file) files)))))
(nconc result (nreverse files))))
(compat--inhibit-prefixed (provide 'compat-25))
;;; compat-25.el ends here

675
lisp/compat/compat-26.el Normal file
View File

@@ -0,0 +1,675 @@
;;; compat-26.el --- Compatibility Layer for Emacs 26.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Find here the functionality added in Emacs 26.1, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `compat-sort'
;; - `line-number-at-pos'
;; - `compat-alist-get'
;; - `string-trim-left'
;; - `string-trim-right'
;; - `string-trim'
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "26.1")
;;;; Defined in eval.c
(compat-defun func-arity (func)
"Return minimum and maximum number of args allowed for FUNC.
FUNC must be a function of some kind.
The returned value is a cons cell (MIN . MAX). MIN is the minimum number
of args. MAX is the maximum number, or the symbol `many', for a
function with `&rest' args, or `unevalled' for a special form."
:realname compat--func-arity
(cond
((or (null func) (and (symbolp func) (not (fboundp func))))
(signal 'void-function func))
((and (symbolp func) (not (null func)))
(compat--func-arity (symbol-function func)))
((eq (car-safe func) 'macro)
(compat--func-arity (cdr func)))
((subrp func)
(subr-arity func))
((memq (car-safe func) '(closure lambda))
;; See lambda_arity from eval.c
(when (eq (car func) 'closure)
(setq func (cdr func)))
(let ((syms-left (if (consp func)
(car func)
(signal 'invalid-function func)))
(min-args 0) (max-args 0) optional)
(catch 'many
(dolist (next syms-left)
(cond
((not (symbolp next))
(signal 'invalid-function func))
((eq next '&rest)
(throw 'many (cons min-args 'many)))
((eq next '&optional)
(setq optional t))
(t (unless optional
(setq min-args (1+ min-args)))
(setq max-args (1+ max-args)))))
(cons min-args max-args))))
((and (byte-code-function-p func) (numberp (aref func 0)))
;; See get_byte_code_arity from bytecode.c
(let ((at (aref func 0)))
(cons (logand at 127)
(if (= (logand at 128) 0)
(ash at -8)
'many))))
((and (byte-code-function-p func) (numberp (aref func 0)))
;; See get_byte_code_arity from bytecode.c
(let ((at (aref func 0)))
(cons (logand at 127)
(if (= (logand at 128) 0)
(ash at -8)
'many))))
((and (byte-code-function-p func) (listp (aref func 0)))
;; Based on `byte-compile-make-args-desc', this is required for
;; old versions of Emacs that don't use a integer for the argument
;; list description, per e2abe5a13dffb08d6371b6a611bc39c3a9ac2bc6.
(let ((arglist (aref func 0)) (mandatory 0) nonrest)
(while (and arglist (not (memq (car arglist) '(&optional &rest))))
(setq mandatory (1+ mandatory))
(setq arglist (cdr arglist)))
(setq nonrest mandatory)
(when (eq (car arglist) '&optional)
(setq arglist (cdr arglist))
(while (and arglist (not (eq (car arglist) '&rest)))
(setq nonrest (1+ nonrest))
(setq arglist (cdr arglist))))
(cons mandatory (if arglist 'many nonrest))))
((autoloadp func)
(autoload-do-load func)
(compat--func-arity func))
((signal 'invalid-function func))))
;;;; Defined in fns.c
(compat-defun assoc (key alist &optional testfn)
"Handle the optional argument TESTFN.
Equality is defined by the function TESTFN, defaulting to
`equal'. TESTFN is called with 2 arguments: a car of an alist
element and KEY. With no optional argument, the function behaves
just like `assoc'."
:prefix t
(if testfn
(catch 'found
(dolist (ent alist)
(when (funcall testfn (car ent) key)
(throw 'found ent))))
(assoc key alist)))
(compat-defun mapcan (func sequence)
"Apply FUNC to each element of SEQUENCE.
Concatenate the results by altering them (using `nconc').
SEQUENCE may be a list, a vector, a boolean vector, or a string."
(apply #'nconc (mapcar func sequence)))
;;* UNTESTED
(compat-defun line-number-at-pos (&optional position absolute)
"Handle optional argument ABSOLUTE:
If the buffer is narrowed, the return value by default counts the lines
from the beginning of the accessible portion of the buffer. But if the
second optional argument ABSOLUTE is non-nil, the value counts the lines
from the absolute start of the buffer, disregarding the narrowing."
:prefix t
(if absolute
(save-restriction
(widen)
(line-number-at-pos position))
(line-number-at-pos position)))
;;;; Defined in subr.el
(declare-function compat--alist-get-full-elisp "compat-25"
(key alist &optional default remove testfn))
(compat-defun alist-get (key alist &optional default remove testfn)
"Handle TESTFN manually."
:realname compat--alist-get-handle-testfn
:prefix t
(if testfn
(compat--alist-get-full-elisp key alist default remove testfn)
(alist-get key alist default remove)))
(gv-define-expander compat-alist-get
(lambda (do key alist &optional default remove testfn)
(macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist
(macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
(compat-assoc ,k ,getter ,testfn)
(assq ,k ,getter))
(funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default))
(lambda (v)
(macroexp-let2 nil v v
(let ((set-exp
`(if ,p (setcdr ,p ,v)
,(funcall setter
`(cons (setq ,p (cons ,k ,v))
,getter)))))
`(progn
,(cond
((null remove) set-exp)
((or (eql v default)
(and (eq (car-safe v) 'quote)
(eq (car-safe default) 'quote)
(eql (cadr v) (cadr default))))
`(if ,p ,(funcall setter `(delq ,p ,getter))))
(t
`(cond
((not (eql ,default ,v)) ,set-exp)
(,p ,(funcall setter
`(delq ,p ,getter))))))
,v))))))))))
(compat-defun string-trim-left (string &optional regexp)
"Trim STRING of leading string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
:realname compat--string-trim-left
:prefix t
(if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
(substring string (match-end 0))
string))
(compat-defun string-trim-right (string &optional regexp)
"Trim STRING of trailing string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
:realname compat--string-trim-right
:prefix t
(let ((i (string-match-p
(concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
string)))
(if i (substring string 0 i) string)))
(compat-defun string-trim (string &optional trim-left trim-right)
"Trim STRING of leading with and trailing matching TRIM-LEFT and TRIM-RIGHT.
TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
:prefix t
;; `string-trim-left' and `string-trim-right' were moved from subr-x
;; to subr in Emacs 27, so to avoid loading subr-x we use the
;; compatibility function here:
(compat--string-trim-left
(compat--string-trim-right
string
trim-right)
trim-left))
(compat-defun caaar (x)
"Return the `car' of the `car' of the `car' of X."
(declare (pure t))
(car (car (car x))))
(compat-defun caadr (x)
"Return the `car' of the `car' of the `cdr' of X."
(declare (pure t))
(car (car (cdr x))))
(compat-defun cadar (x)
"Return the `car' of the `cdr' of the `car' of X."
(declare (pure t))
(car (cdr (car x))))
(compat-defun caddr (x)
"Return the `car' of the `cdr' of the `cdr' of X."
(declare (pure t))
(car (cdr (cdr x))))
(compat-defun cdaar (x)
"Return the `cdr' of the `car' of the `car' of X."
(declare (pure t))
(cdr (car (car x))))
(compat-defun cdadr (x)
"Return the `cdr' of the `car' of the `cdr' of X."
(declare (pure t))
(cdr (car (cdr x))))
(compat-defun cddar (x)
"Return the `cdr' of the `cdr' of the `car' of X."
(declare (pure t))
(cdr (cdr (car x))))
(compat-defun cdddr (x)
"Return the `cdr' of the `cdr' of the `cdr' of X."
(declare (pure t))
(cdr (cdr (cdr x))))
(compat-defun caaaar (x)
"Return the `car' of the `car' of the `car' of the `car' of X."
(declare (pure t))
(car (car (car (car x)))))
(compat-defun caaadr (x)
"Return the `car' of the `car' of the `car' of the `cdr' of X."
(declare (pure t))
(car (car (car (cdr x)))))
(compat-defun caadar (x)
"Return the `car' of the `car' of the `cdr' of the `car' of X."
(declare (pure t))
(car (car (cdr (car x)))))
(compat-defun caaddr (x)
"Return the `car' of the `car' of the `cdr' of the `cdr' of X."
(declare (pure t))
(car (car (cdr (cdr x)))))
(compat-defun cadaar (x)
"Return the `car' of the `cdr' of the `car' of the `car' of X."
(declare (pure t))
(car (cdr (car (car x)))))
(compat-defun cadadr (x)
"Return the `car' of the `cdr' of the `car' of the `cdr' of X."
(declare (pure t))
(car (cdr (car (cdr x)))))
(compat-defun caddar (x)
"Return the `car' of the `cdr' of the `cdr' of the `car' of X."
(declare (pure t))
(car (cdr (cdr (car x)))))
(compat-defun cadddr (x)
"Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
(declare (pure t))
(car (cdr (cdr (cdr x)))))
(compat-defun cdaaar (x)
"Return the `cdr' of the `car' of the `car' of the `car' of X."
(declare (pure t))
(cdr (car (car (car x)))))
(compat-defun cdaadr (x)
"Return the `cdr' of the `car' of the `car' of the `cdr' of X."
(declare (pure t))
(cdr (car (car (cdr x)))))
(compat-defun cdadar (x)
"Return the `cdr' of the `car' of the `cdr' of the `car' of X."
(declare (pure t))
(cdr (car (cdr (car x)))))
(compat-defun cdaddr (x)
"Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
(declare (pure t))
(cdr (car (cdr (cdr x)))))
(compat-defun cddaar (x)
"Return the `cdr' of the `cdr' of the `car' of the `car' of X."
(declare (pure t))
(cdr (cdr (car (car x)))))
(compat-defun cddadr (x)
"Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
(declare (pure t))
(cdr (cdr (car (cdr x)))))
(compat-defun cdddar (x)
"Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
(declare (pure t))
(cdr (cdr (cdr (car x)))))
(compat-defun cddddr (x)
"Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
(declare (pure t))
(cdr (cdr (cdr (cdr x)))))
(compat-defvar gensym-counter 0
"Number used to construct the name of the next symbol created by `gensym'.")
(compat-defun gensym (&optional prefix)
"Return a new uninterned symbol.
The name is made by appending `gensym-counter' to PREFIX.
PREFIX is a string, and defaults to \"g\"."
(let ((num (prog1 gensym-counter
(setq gensym-counter
(1+ gensym-counter)))))
(make-symbol (format "%s%d" (or prefix "g") num))))
;;;; Defined in files.el
(declare-function temporary-file-directory nil)
;;* UNTESTED
(compat-defun make-nearby-temp-file (prefix &optional dir-flag suffix)
"Create a temporary file as close as possible to `default-directory'.
If PREFIX is a relative file name, and `default-directory' is a
remote file name or located on a mounted file systems, the
temporary file is created in the directory returned by the
function `temporary-file-directory'. Otherwise, the function
`make-temp-file' is used. PREFIX, DIR-FLAG and SUFFIX have the
same meaning as in `make-temp-file'."
(let ((handler (find-file-name-handler
default-directory 'make-nearby-temp-file)))
(if (and handler (not (file-name-absolute-p default-directory)))
(funcall handler 'make-nearby-temp-file prefix dir-flag suffix)
(let ((temporary-file-directory (temporary-file-directory)))
(make-temp-file prefix dir-flag suffix)))))
(compat-defvar mounted-file-systems
(eval-when-compile
(if (memq system-type '(windows-nt cygwin))
"^//[^/]+/"
(concat
"^" (regexp-opt '("/afs/" "/media/" "/mnt" "/net/" "/tmp_mnt/")))))
"File systems that ought to be mounted.")
(compat-defun file-local-name (file)
"Return the local name component of FILE.
This function removes from FILE the specification of the remote host
and the method of accessing the host, leaving only the part that
identifies FILE locally on the remote system.
The returned file name can be used directly as argument of
`process-file', `start-file-process', or `shell-command'."
:realname compat--file-local-name
(or (file-remote-p file 'localname) file))
(compat-defun file-name-quoted-p (name &optional top)
"Whether NAME is quoted with prefix \"/:\".
If NAME is a remote file name and TOP is nil, check the local part of NAME."
:realname compat--file-name-quoted-p
(let ((file-name-handler-alist (unless top file-name-handler-alist)))
(string-prefix-p "/:" (compat--file-local-name name))))
(compat-defun file-name-quote (name &optional top)
"Add the quotation prefix \"/:\" to file NAME.
If NAME is a remote file name and TOP is nil, the local part of
NAME is quoted. If NAME is already a quoted file name, NAME is
returned unchanged."
(let ((file-name-handler-alist (unless top file-name-handler-alist)))
(if (compat--file-name-quoted-p name top)
name
(concat (file-remote-p name) "/:" (compat--file-local-name name)))))
;;* UNTESTED
(compat-defun temporary-file-directory ()
"The directory for writing temporary files.
In case of a remote `default-directory', this is a directory for
temporary files on that remote host. If such a directory does
not exist, or `default-directory' ought to be located on a
mounted file system (see `mounted-file-systems'), the function
returns `default-directory'.
For a non-remote and non-mounted `default-directory', the value of
the variable `temporary-file-directory' is returned."
(let ((handler (find-file-name-handler
default-directory 'temporary-file-directory)))
(if handler
(funcall handler 'temporary-file-directory)
(if (string-match mounted-file-systems default-directory)
default-directory
temporary-file-directory))))
;;* UNTESTED
(compat-defun file-attribute-type (attributes)
"The type field in ATTRIBUTES returned by `file-attributes'.
The value is either t for directory, string (name linked to) for
symbolic link, or nil."
(nth 0 attributes))
;;* UNTESTED
(compat-defun file-attribute-link-number (attributes)
"Return the number of links in ATTRIBUTES returned by `file-attributes'."
(nth 1 attributes))
;;* UNTESTED
(compat-defun file-attribute-user-id (attributes)
"The UID field in ATTRIBUTES returned by `file-attributes'.
This is either a string or a number. If a string value cannot be
looked up, a numeric value, either an integer or a float, is
returned."
(nth 2 attributes))
;;* UNTESTED
(compat-defun file-attribute-group-id (attributes)
"The GID field in ATTRIBUTES returned by `file-attributes'.
This is either a string or a number. If a string value cannot be
looked up, a numeric value, either an integer or a float, is
returned."
(nth 3 attributes))
;;* UNTESTED
(compat-defun file-attribute-access-time (attributes)
"The last access time in ATTRIBUTES returned by `file-attributes'.
This a Lisp timestamp in the style of `current-time'."
(nth 4 attributes))
;;* UNTESTED
(compat-defun file-attribute-modification-time (attributes)
"The modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of the last change to the file's contents, and
is a Lisp timestamp in the style of `current-time'."
(nth 5 attributes))
;;* UNTESTED
(compat-defun file-attribute-status-change-time (attributes)
"The status modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of last change to the file's attributes: owner
and group, access mode bits, etc., and is a Lisp timestamp in the
style of `current-time'."
(nth 6 attributes))
;;* UNTESTED
(compat-defun file-attribute-size (attributes)
"The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'."
(nth 7 attributes))
;;* UNTESTED
(compat-defun file-attribute-modes (attributes)
"The file modes in ATTRIBUTES returned by `file-attributes'.
This is a string of ten letters or dashes as in ls -l."
(nth 8 attributes))
;;* UNTESTED
(compat-defun file-attribute-inode-number (attributes)
"The inode number in ATTRIBUTES returned by `file-attributes'.
It is a nonnegative integer."
(nth 10 attributes))
;;* UNTESTED
(compat-defun file-attribute-device-number (attributes)
"The file system device number in ATTRIBUTES returned by `file-attributes'.
It is an integer."
(nth 11 attributes))
(compat-defun file-attribute-collect (attributes &rest attr-names)
"Return a sublist of ATTRIBUTES returned by `file-attributes'.
ATTR-NAMES are symbols with the selected attribute names.
Valid attribute names are: type, link-number, user-id, group-id,
access-time, modification-time, status-change-time, size, modes,
inode-number and device-number."
(let ((idx '((type . 0)
(link-number . 1)
(user-id . 2)
(group-id . 3)
(access-time . 4)
(modification-time . 5)
(status-change-time . 6)
(size . 7)
(modes . 8)
(inode-number . 10)
(device-number . 11)))
result)
(while attr-names
(let ((attr (pop attr-names)))
(if (assq attr idx)
(push (nth (cdr (assq attr idx))
attributes)
result)
(error "Wrong attribute name '%S'" attr))))
(nreverse result)))
;;;; Defined in subr-x.el
(compat-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."
:realname compat--if-let*
:feature 'subr-x
(declare (indent 2)
(debug ((&rest [&or symbolp (symbolp form) (form)])
body)))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(or (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(if ,(caar list) ,then ,@else))))
(compat-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."
;; :feature 'subr-x
(declare (indent 1) (debug if-let*))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(or (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(when ,(caar list) ,@body))))
(compat-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."
:feature 'subr-x
(declare (indent 1) (debug if-let*))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(or (cadr var) (car var))))
list)
(when (or (cdr var) (consp (car var)))
(setq last (caar list))))
`(let* ,(nreverse list)
(if ,(caar list) ,(macroexp-progn (or body '(t)))))))
;;;; Defined in image.el
;;* UNTESTED
(compat-defun image-property (image property)
"Return the value of PROPERTY in IMAGE.
Properties can be set with
(setf (image-property IMAGE PROPERTY) VALUE)
If VALUE is nil, PROPERTY is removed from IMAGE."
(plist-get (cdr image) property))
;;* UNTESTED
(unless (get 'image-property 'gv-expander)
(gv-define-setter image-property (image property value)
(let ((image* (make-symbol "image"))
(property* (make-symbol "property"))
(value* (make-symbol "value")))
`(let ((,image* ,image)
(,property* ,property)
(,value* ,value))
(if
(null ,value*)
(while
(cdr ,image*)
(if
(eq
(cadr ,image*)
,property*)
(setcdr ,image*
(cdddr ,image*))
(setq ,image*
(cddr ,image*))))
(setcdr ,image*
(plist-put
(cdr ,image*)
,property* ,value*)))))))
;;;; Defined in rmc.el
;;*UNTESTED
(compat-defun read-multiple-choice
(prompt choices &optional _help-string _show-help long-form)
"Ask user to select an entry from CHOICES, promting with PROMPT.
This function allows to ask the user a multiple-choice question.
CHOICES should be a list of the form (KEY NAME [DESCRIPTION]).
KEY is a character the user should type to select the entry.
NAME is a short name for the entry to be displayed while prompting
\(if there's no room, it might be shortened).
If LONG-FORM, do a `completing-read' over the NAME elements in
CHOICES instead."
:note "This is a partial implementation of `read-multiple-choice', that
among other things doesn't offer any help and ignores the
optional DESCRIPTION field."
(if long-form
(let ((options (mapconcat #'cadr choices "/"))
choice)
(setq prompt (concat prompt " (" options "): "))
(setq choice (completing-read prompt (mapcar #'cadr choices) nil t))
(catch 'found
(dolist (option choices)
(when (string= choice (cadr option))
(throw 'found option)))
(error "Invalid choice")))
(let ((options
(mapconcat
(lambda (opt)
(format
"[%s] %s"
(key-description (string (car opt)))
(cadr opt)))
choices " "))
choice)
(setq prompt (concat prompt " (" options "): "))
(while (not (setq choice (assq (read-char prompt) choices)))
(message "Invalid choice")
(sit-for 1))
choice)))
(compat--inhibit-prefixed (provide 'compat-26))
;;; compat-26.el ends here

764
lisp/compat/compat-27.el Normal file
View File

@@ -0,0 +1,764 @@
;;; compat-27.el --- Compatibility Layer for Emacs 27.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Find here the functionality added in Emacs 27.1, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions or macros:
;;
;; - `compat-recenter'
;; - `compat-lookup-key'
;; - `compat-setq-local'
;; - `compat-assoc-delete-all'
;; - `compat-file-size-human-readable'
;; - `compat-executable-find'
;; - `compat-regexp-opt'
;; - `compat-dired-get-marked-files'
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "27.1")
;;;; Defined in fns.c
(compat-defun proper-list-p (object)
"Return OBJECT's length if it is a proper list, nil otherwise.
A proper list is neither circular nor dotted (i.e., its last cdr
is nil)."
:min-version "26.1"
:max-version "26.3"
:realname compat--proper-list-p-length-signal
(condition-case nil
(and (listp object) (length object))
(wrong-type-argument nil)
(circular-list nil)))
(compat-defun proper-list-p (object)
"Return OBJECT's length if it is a proper list, nil otherwise.
A proper list is neither circular nor dotted (i.e., its last cdr
is nil)."
:max-version "25.3"
:realname compat--proper-list-p-tortoise-hare
(when (listp object)
(catch 'cycle
(let ((hare object) (tortoise object)
(max 2) (q 2))
(while (consp hare)
(setq hare (cdr hare))
(when (and (or (/= 0 (setq q (1- q)))
(ignore
(setq max (ash max 1)
q max
tortoise hare)))
(eq hare tortoise))
(throw 'cycle nil)))
(and (null hare) (length object))))))
(compat-defun string-distance (string1 string2 &optional bytecompare)
"Return Levenshtein distance between STRING1 and STRING2.
The distance is the number of deletions, insertions, and substitutions
required to transform STRING1 into STRING2.
If BYTECOMPARE is nil or omitted, compute distance in terms of characters.
If BYTECOMPARE is non-nil, compute distance in terms of bytes.
Letter-case is significant, but text properties are ignored."
;; https://en.wikipedia.org/wiki/Levenshtein_distance
(let ((s1 (if bytecompare
(encode-coding-string string1 'raw-text)
(concat string1 "")))
(s2 (if bytecompare
(encode-coding-string string2 'raw-text)
string2)))
(let* ((len1 (length s1))
(len2 (length s2))
(column (make-vector (1+ len1) 0)))
(dotimes (y len1)
(setf (aref column (1+ y)) y))
(dotimes (x len2)
(setf (aref column 0) (1+ x))
(let ((lastdiag x) olddiag)
(dotimes (y len1)
(setf olddiag (aref column (1+ y))
(aref column (1+ y))
(min (+ (if (= (aref s1 y) (aref s2 x)) 0 1)
lastdiag)
(1+ (aref column (1+ y)))
(1+ (aref column y)))
lastdiag olddiag))))
(aref column len1))))
;;;; Defined in window.c
(compat-defun recenter (&optional arg redisplay)
"Handle optional argument REDISPLAY."
:prefix t
(recenter arg)
(when (and redisplay recenter-redisplay)
(redisplay)))
;;;; Defined in keymap.c
(compat-defun lookup-key (keymap key &optional accept-default)
"Allow for KEYMAP to be a list of keymaps."
:prefix t
(cond
((keymapp keymap)
(lookup-key keymap key accept-default))
((listp keymap)
(catch 'found
(dolist (map keymap)
(let ((fn (lookup-key map key accept-default)))
(when fn (throw 'found fn))))))
((signal 'wrong-type-argument (list 'keymapp keymap)))))
;;;; Defined in json.c
(declare-function json-parse-string nil (string &rest args))
(declare-function json-encode "json" (object))
(declare-function json-read-from-string "json" (string))
(declare-function json-read "json" ())
(defvar json-encoding-pretty-print)
(defvar json-object-type)
(defvar json-array-type)
(defvar json-false)
(defvar json-null)
;; The function is declared to satisfy the byte compiler while testing
;; if native JSON parsing is available.;
(declare-function json-serialize nil (object &rest args))
(compat-defun json-serialize (object &rest args)
"Return the JSON representation of OBJECT as a string.
OBJECT must be t, a number, string, vector, hashtable, alist, plist,
or the Lisp equivalents to the JSON null and false values, and its
elements must recursively consist of the same kinds of values. t will
be converted to the JSON true value. Vectors will be converted to
JSON arrays, whereas hashtables, alists and plists are converted to
JSON objects. Hashtable keys must be strings without embedded null
characters and must be unique within each object. Alist and plist
keys must be symbols; if a key is duplicate, the first instance is
used.
The Lisp equivalents to the JSON null and false values are
configurable in the arguments ARGS, a list of keyword/argument pairs:
The keyword argument `:null-object' specifies which object to use
to represent a JSON null value. It defaults to `:null'.
The keyword argument `:false-object' specifies which object to use to
represent a JSON false value. It defaults to `:false'.
In you specify the same value for `:null-object' and `:false-object',
a potentially ambiguous situation, the JSON output will not contain
any JSON false values."
:cond (not (condition-case nil
(equal (json-serialize '()) "{}")
(:success t)
(void-function nil)
(json-unavailable nil)))
:realname compat--json-serialize
(require 'json)
(letrec ((fix (lambda (obj)
(cond
((hash-table-p obj)
(let ((ht (copy-hash-table obj)))
(maphash
(lambda (key val)
(unless (stringp key)
(signal
'wrong-type-argument
(list 'stringp key)))
(puthash key (funcall fix val) ht))
obj)
ht))
((and (listp obj) (consp (car obj))) ;alist
(mapcar
(lambda (ent)
(cons (symbol-name (car ent))
(funcall fix (cdr ent))))
obj))
((listp obj) ;plist
(let (alist)
(while obj
(push (cons (cond
((keywordp (car obj))
(substring
(symbol-name (car obj))
1))
((symbolp (car obj))
(symbol-name (car obj)))
((signal
'wrong-type-argument
(list 'symbolp (car obj)))))
(funcall fix (cadr obj)))
alist)
(unless (consp (cdr obj))
(signal 'wrong-type-argument '(consp nil)))
(setq obj (cddr obj)))
(nreverse alist)))
((vectorp obj)
(let ((vec (make-vector (length obj) nil)))
(dotimes (i (length obj))
(aset vec i (funcall fix (aref obj i))))
vec))
(obj))))
(json-encoding-pretty-print nil)
(json-false (or (plist-get args :false-object) :false))
(json-null (or (plist-get args :null-object) :null)))
(json-encode (funcall fix object))))
(compat-defun json-insert (object &rest args)
"Insert the JSON representation of OBJECT before point.
This is the same as (insert (json-serialize OBJECT)), but potentially
faster. See the function `json-serialize' for allowed values of
OBJECT."
:cond (not (condition-case nil
(equal (json-serialize '()) "{}")
(:success t)
(void-function nil)
(json-unavailable nil)))
(insert (apply #'compat--json-serialize object args)))
(compat-defun json-parse-string (string &rest args)
"Parse the JSON STRING into a Lisp object.
This is essentially the reverse operation of `json-serialize', which
see. The returned object will be the JSON null value, the JSON false
value, t, a number, a string, a vector, a list, a hashtable, an alist,
or a plist. Its elements will be further objects of these types. If
there are duplicate keys in an object, all but the last one are
ignored. If STRING doesn't contain a valid JSON object, this function
signals an error of type `json-parse-error'.
The arguments ARGS are a list of keyword/argument pairs:
The keyword argument `:object-type' specifies which Lisp type is used
to represent objects; it can be `hash-table', `alist' or `plist'. It
defaults to `hash-table'.
The keyword argument `:array-type' specifies which Lisp type is used
to represent arrays; it can be `array' (the default) or `list'.
The keyword argument `:null-object' specifies which object to use
to represent a JSON null value. It defaults to `:null'.
The keyword argument `:false-object' specifies which object to use to
represent a JSON false value. It defaults to `:false'."
:cond (not (condition-case nil
(equal (json-serialize '()) "{}")
(:success t)
(void-function nil)
(json-unavailable nil)))
(require 'json)
(condition-case err
(let ((json-object-type (or (plist-get args :object-type) 'hash-table))
(json-array-type (or (plist-get args :array-type) 'vector))
(json-false (or (plist-get args :false-object) :false))
(json-null (or (plist-get args :null-object) :null)))
(when (eq json-array-type 'array)
(setq json-array-type 'vector))
(json-read-from-string string))
(json-error (signal 'json-parse-error err))))
(compat-defun json-parse-buffer (&rest args)
"Read JSON object from current buffer starting at point.
Move point after the end of the object if parsing was successful.
On error, don't move point.
The returned object will be a vector, list, hashtable, alist, or
plist. Its elements will be the JSON null value, the JSON false
value, t, numbers, strings, or further vectors, lists, hashtables,
alists, or plists. If there are duplicate keys in an object, all
but the last one are ignored.
If the current buffer doesn't contain a valid JSON object, the
function signals an error of type `json-parse-error'.
The arguments ARGS are a list of keyword/argument pairs:
The keyword argument `:object-type' specifies which Lisp type is used
to represent objects; it can be `hash-table', `alist' or `plist'. It
defaults to `hash-table'.
The keyword argument `:array-type' specifies which Lisp type is used
to represent arrays; it can be `array' (the default) or `list'.
The keyword argument `:null-object' specifies which object to use
to represent a JSON null value. It defaults to `:null'.
The keyword argument `:false-object' specifies which object to use to
represent a JSON false value. It defaults to `:false'."
:cond (not (condition-case nil
(equal (json-serialize '()) "{}")
(:success t)
(void-function nil)
(json-unavailable nil)))
(require 'json)
(condition-case err
(let ((json-object-type (or (plist-get args :object-type) 'hash-table))
(json-array-type (or (plist-get args :array-type) 'vector))
(json-false (or (plist-get args :false-object) :false))
(json-null (or (plist-get args :null-object) :null)))
(when (eq json-array-type 'array)
(setq json-array-type 'vector))
(json-read))
(json-error (signal 'json-parse-buffer err))))
;;;; Defined in timefns.c
(compat-defun time-equal-p (t1 t2)
"Return non-nil if time value T1 is equal to time value T2.
A nil value for either argument stands for the current time."
:note "This function is not as accurate as the actual `time-equal-p'."
(cond
((eq t1 t2))
((and (consp t1) (consp t2))
(equal t1 t2))
((let ((now (current-time)))
;; Due to inaccuracies and the relatively slow evaluating of
;; Emacs Lisp compared to C, we allow for slight inaccuracies
;; (less than a millisecond) when comparing time values.
(< (abs (- (float-time (or t1 now))
(float-time (or t2 now))))
1e-5)))))
;;;; Defined in fileio.c
(compat-defun file-name-absolute-p (filename)
"Return t if FILENAME is an absolute file name.
On Unix, absolute file names start with `/'. In Emacs, an absolute
file name can also start with an initial `~' or `~USER' component,
where USER is a valid login name."
;; See definitions in filename.h
(let ((seperator
(eval-when-compile
(if (memq system-type '(cygwin windows-nt ms-dos))
"[\\/]" "/")))
(drive
(eval-when-compile
(cond
((memq system-type '(windows-nt ms-dos))
"\\`[A-Za-z]:[\\/]")
((eq system-type 'cygwin)
"\\`\\([\\/]\\|[A-Za-z]:\\)")
("\\`/"))))
(home
(eval-when-compile
(if (memq system-type '(cygwin windows-nt ms-dos))
"\\`~[\\/]" "\\`~/")))
(user-home
(eval-when-compile
(format "\\`\\(~.*?\\)\\(%s.*\\)?$"
(if (memq system-type '(cygwin windows-nt ms-dos))
"[\\/]" "/")))))
(or (and (string-match-p drive filename) t)
(and (string-match-p home filename) t)
(save-excursion
(when (string-match user-home filename)
(let ((init (match-string 1 filename)))
(not (string=
(file-name-base (expand-file-name init))
init))))))))
;;;; Defined in subr.el
(compat-defmacro setq-local (&rest pairs)
"Handle multiple assignments."
:prefix t
(unless (zerop (mod (length pairs) 2))
(error "PAIRS must have an even number of variable/value members"))
(let (body)
(while pairs
(let* ((sym (pop pairs))
(val (pop pairs)))
(unless (symbolp sym)
(error "Attempting to set a non-symbol: %s" (car pairs)))
(push `(set (make-local-variable ,sym) ,val)
body)))
(cons 'progn (nreverse body))))
(compat-defun provided-mode-derived-p (mode &rest modes)
"Non-nil if MODE is derived from one of MODES.
Uses the `derived-mode-parent' property of the symbol to trace backwards.
If you just want to check `major-mode', use `derived-mode-p'."
:realname compat--provided-mode-derived-p
;; If MODE is an alias, then look up the real mode function first.
(let ((alias (symbol-function mode)))
(when (and alias (symbolp alias))
(setq mode alias)))
(while
(and
(not (memq mode modes))
(let* ((parent (get mode 'derived-mode-parent))
(parentfn (symbol-function parent)))
(setq mode (if (and parentfn (symbolp parentfn)) parentfn parent)))))
mode)
;;* UNTESTED
(defun derived-mode-p (&rest modes)
"Non-nil if the current major mode is derived from one of MODES.
Uses the `derived-mode-parent' property of the symbol to trace backwards."
(apply #'compat--provided-mode-derived-p major-mode modes))
;;* UNTESTED
(compat-defmacro ignore-error (condition &rest body)
"Execute BODY; if the error CONDITION occurs, return nil.
Otherwise, return result of last form in BODY.
CONDITION can also be a list of error conditions."
(declare (debug t) (indent 1))
`(condition-case nil (progn ,@body) (,condition nil)))
;;* UNTESTED
(compat-defmacro dolist-with-progress-reporter (spec reporter-or-message &rest body)
"Loop over a list and report progress in the echo area.
Evaluate BODY with VAR bound to each car from LIST, in turn.
Then evaluate RESULT to get return value, default nil.
REPORTER-OR-MESSAGE is a progress reporter object or a string. In the latter
case, use this string to create a progress reporter.
At each iteration, print the reporter message followed by progress
percentage in the echo area. After the loop is finished,
print the reporter message followed by the word \"done\".
\(fn (VAR LIST [RESULT]) REPORTER-OR-MESSAGE BODY...)"
(declare (indent 2) (debug ((symbolp form &optional form) form body)))
(let ((prep (make-symbol "--dolist-progress-reporter--"))
(count (make-symbol "--dolist-count--"))
(list (make-symbol "--dolist-list--")))
`(let ((,prep ,reporter-or-message)
(,count 0)
(,list ,(cadr spec)))
(when (stringp ,prep)
(setq ,prep (make-progress-reporter ,prep 0 (1- (length ,list)))))
(dolist (,(car spec) ,list)
,@body
(progress-reporter-update ,prep (setq ,count (1+ ,count))))
(progress-reporter-done ,prep)
(or ,@(cdr (cdr spec)) nil))))
(compat-defun flatten-tree (tree)
"Return a \"flattened\" copy of TREE.
In other words, return a list of the non-nil terminal nodes, or
leaves, of the tree of cons cells rooted at TREE. Leaves in the
returned list are in the same order as in TREE.
\(flatten-tree \\='(1 (2 . 3) nil (4 5 (6)) 7))
=> (1 2 3 4 5 6 7)"
(let (elems)
(while (consp tree)
(let ((elem (pop tree)))
(while (consp elem)
(push (cdr elem) tree)
(setq elem (car elem)))
(if elem (push elem elems))))
(if tree (push tree elems))
(nreverse elems)))
(compat-defun xor (cond1 cond2)
"Return the boolean exclusive-or of COND1 and COND2.
If only one of the arguments is non-nil, return it; otherwise
return nil."
(declare (pure t) (side-effect-free error-free))
(cond ((not cond1) cond2)
((not cond2) cond1)))
(compat-defvar regexp-unmatchable "\\`a\\`"
"Standard regexp guaranteed not to match any string at all."
:constant t)
(compat-defun assoc-delete-all (key alist &optional test)
"Delete from ALIST all elements whose car is KEY.
Compare keys with TEST. Defaults to `equal'.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
:prefix t
(unless test (setq test #'equal))
(while (and (consp (car alist))
(funcall test (caar alist) key))
(setq alist (cdr alist)))
(let ((tail alist) tail-cdr)
(while (setq tail-cdr (cdr tail))
(if (and (consp (car tail-cdr))
(funcall test (caar tail-cdr) key))
(setcdr tail (cdr tail-cdr))
(setq tail tail-cdr))))
alist)
;;;; Defined in simple.el
;;* UNTESTED
(compat-defun decoded-time-second (time)
"The seconds in TIME, which is a value returned by `decode-time'.
This is an integer between 0 and 60 (inclusive). (60 is a leap
second, which only some operating systems support.)"
(nth 0 time))
;;* UNTESTED
(compat-defun decoded-time-minute (time)
"The minutes in TIME, which is a value returned by `decode-time'.
This is an integer between 0 and 59 (inclusive)."
(nth 1 time))
;;* UNTESTED
(compat-defun decoded-time-hour (time)
"The hours in TIME, which is a value returned by `decode-time'.
This is an integer between 0 and 23 (inclusive)."
(nth 2 time))
;;* UNTESTED
(compat-defun decoded-time-day (time)
"The day-of-the-month in TIME, which is a value returned by `decode-time'.
This is an integer between 1 and 31 (inclusive)."
(nth 3 time))
;;* UNTESTED
(compat-defun decoded-time-month (time)
"The month in TIME, which is a value returned by `decode-time'.
This is an integer between 1 and 12 (inclusive). January is 1."
(nth 4 time))
;;* UNTESTED
(compat-defun decoded-time-year (time)
"The year in TIME, which is a value returned by `decode-time'.
This is a four digit integer."
(nth 5 time))
;;* UNTESTED
(compat-defun decoded-time-weekday (time)
"The day-of-the-week in TIME, which is a value returned by `decode-time'.
This is a number between 0 and 6, and 0 is Sunday."
(nth 6 time))
;;* UNTESTED
(compat-defun decoded-time-dst (time)
"The daylight saving time in TIME, which is a value returned by `decode-time'.
This is t if daylight saving time is in effect, and nil if not."
(nth 7 time))
;;* UNTESTED
(compat-defun decoded-time-zone (time)
"The time zone in TIME, which is a value returned by `decode-time'.
This is an integer indicating the UTC offset in seconds, i.e.,
the number of seconds east of Greenwich."
(nth 8 time))
;; TODO define gv-setters
;;;; Defined in files.el
(compat-defun file-size-human-readable (file-size &optional flavor space unit)
"Handle the optional third and forth argument:
Optional third argument SPACE is a string put between the number and unit.
It defaults to the empty string. We recommend a single space or
non-breaking space, unless other constraints prohibit a space in that
position.
Optional fourth argument UNIT is the unit to use. It defaults to \"B\"
when FLAVOR is `iec' and the empty string otherwise. We recommend \"B\"
in all cases, since that is the standard symbol for byte."
:prefix t
(let ((power (if (or (null flavor) (eq flavor 'iec))
1024.0
1000.0))
(prefixes '("" "k" "M" "G" "T" "P" "E" "Z" "Y")))
(while (and (>= file-size power) (cdr prefixes))
(setq file-size (/ file-size power)
prefixes (cdr prefixes)))
(let* ((prefix (car prefixes))
(prefixed-unit (if (eq flavor 'iec)
(concat
(if (string= prefix "k") "K" prefix)
(if (string= prefix "") "" "i")
(or unit "B"))
(concat prefix unit))))
(format (if (and (>= (mod file-size 1.0) 0.05)
(< (mod file-size 1.0) 0.95))
"%.1f%s%s"
"%.0f%s%s")
file-size
(if (string= prefixed-unit "") "" (or space ""))
prefixed-unit))))
(declare-function compat--file-name-quote "compat-26"
(name &optional top))
;;*UNTESTED
(compat-defun exec-path ()
"Return list of directories to search programs to run in remote subprocesses.
The remote host is identified by `default-directory'. For remote
hosts that do not support subprocesses, this returns nil.
If `default-directory' is a local directory, this function returns
the value of the variable `exec-path'."
:realname compat--exec-path
(cond
((let ((handler (find-file-name-handler default-directory 'exec-path)))
;; FIXME: The handler was added in 27.1, and this compatibility
;; function only applies to versions of Emacs before that.
(when handler
(condition-case nil
(funcall handler 'exec-path)
(error nil)))))
((file-remote-p default-directory)
;; TODO: This is not completely portable, even if "sh" and
;; "getconf" should be provided on every POSIX system, the chance
;; of this not working are greater than zero.
;;
;; FIXME: This invokes a shell process every time exec-path is
;; called. It should instead be cached on a host-local basis.
(with-temp-buffer
(if (condition-case nil
(zerop (process-file "sh" nil t nil "-c" "getconf PATH"))
(file-missing t))
(list "/bin" "/usr/bin")
(let (path)
(while (re-search-forward "\\([^:]+?\\)[\n:]" nil t)
(push (match-string 1) path))
(nreverse path)))))
(exec-path)))
(declare-function compat--file-local-name "compat-26"
(file))
;;*UNTESTED
(compat-defun executable-find (command &optional remote)
"Search for COMMAND in `exec-path' and return the absolute file name.
Return nil if COMMAND is not found anywhere in `exec-path'. If
REMOTE is non-nil, search on the remote host indicated by
`default-directory' instead."
:prefix t
(if (and remote (file-remote-p default-directory))
(let ((res (locate-file
command
(mapcar
(apply-partially
#'concat (file-remote-p default-directory))
(compat--exec-path))
exec-suffixes 'file-executable-p)))
(when (stringp res) (compat--file-local-name res)))
(executable-find command)))
;; TODO provide advice for directory-files-recursively
;;;; Defined in format-spec.el
;; TODO provide advice for format-spec
;;;; Defined in regexp-opt.el
(compat-defun regexp-opt (strings &optional paren)
"Handle an empty list of strings."
:prefix t
(if (null strings)
(let ((re "\\`a\\`"))
(cond ((null paren)
(concat "\\(?:" re "\\)"))
((stringp paren)
(concat paren re "\\)"))
((eq paren 'words)
(concat "\\<\\(" re "\\)\\>"))
((eq paren 'symbols)
(concat "\\_\\(<" re "\\)\\_>"))
((concat "\\(" re "\\)"))))
(regexp-opt strings paren)))
;;;; Defined in package.el
(declare-function lm-header "lisp-mnt")
;;* UNTESTED
(compat-defun package-get-version ()
"Return the version number of the package in which this is used.
Assumes it is used from an Elisp file placed inside the top-level directory
of an installed ELPA package.
The return value is a string (or nil in case we can’t find it)."
;; In a sense, this is a lie, but it does just what we want: precompute
;; the version at compile time and hardcodes it into the .elc file!
(declare (pure t))
;; Hack alert!
(let ((file
(or (and (boundp 'byte-compile-current-file) byte-compile-current-file)
load-file-name
buffer-file-name)))
(cond
((null file) nil)
;; Packages are normally installed into directories named "<pkg>-<vers>",
;; so get the version number from there.
((string-match
"/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'"
file)
(match-string 1 file))
;; For packages run straight from the an elpa.git clone, there's no
;; "-<vers>" in the directory name, so we have to fetch the version
;; the hard way.
((let* ((pkgdir (file-name-directory file))
(pkgname (file-name-nondirectory (directory-file-name pkgdir)))
(mainfile (expand-file-name (concat pkgname ".el") pkgdir)))
(when (file-readable-p mainfile)
(require 'lisp-mnt)
(with-temp-buffer
(insert-file-contents mainfile)
(or (lm-header "package-version")
(lm-header "version")))))))))
;;;; Defined in dired.el
(declare-function
dired-get-marked-files "dired.el"
(&optional localp arg filter distinguish-one-marked error))
;;* UNTESTED
(compat-defun dired-get-marked-files
(&optional localp arg filter distinguish-one-marked error)
"Return the marked files’ names as list of strings."
:feature 'dired
:prefix t
(let ((result (dired-get-marked-files localp arg filter distinguish-one-marked)))
(if (and (null result) error)
(user-error (if (stringp error) error "No files specified"))
result)))
;;;; Defined in time-date.el
(compat-defun date-days-in-month (year month)
"The number of days in MONTH in YEAR."
:feature 'time-date
(unless (and (numberp month)
(<= 1 month)
(<= month 12))
(error "Month %s is invalid" month))
(if (= month 2)
(if (date-leap-year-p year)
29
28)
(if (memq month '(1 3 5 7 8 10 12))
31
30)))
(compat--inhibit-prefixed (provide 'compat-27))
;;; compat-27.el ends here

882
lisp/compat/compat-28.el Normal file
View File

@@ -0,0 +1,882 @@
;;; compat-28.el --- Compatibility Layer for Emacs 28.1 -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; URL: https://git.sr.ht/~pkal/compat/
;; Keywords: lisp
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Find here the functionality added in Emacs 28.1, needed by older
;; versions.
;;
;; Only load this library if you need to use one of the following
;; functions:
;;
;; - `unlock-buffer'
;; - `string-width'
;; - `directory-files'
;; - `json-serialize'
;; - `json-insert'
;; - `json-parse-string'
;; - `json-parse-buffer'
;; - `count-windows'
;;; Code:
(require 'compat-macs "compat-macs.el")
(compat-declare-version "28.1")
;;;; Defined in fns.c
;;* INCOMPLETE FEATURE: Should handle multibyte regular expressions
(compat-defun string-search (needle haystack &optional start-pos)
"Search for the string NEEDLE in the strign HAYSTACK.
The return value is the position of the first occurrence of
NEEDLE in HAYSTACK, or nil if no match was found.
The optional START-POS argument says where to start searching in
HAYSTACK and defaults to zero (start at the beginning).
It must be between zero and the length of HAYSTACK, inclusive.
Case is always significant and text properties are ignored."
:note "Prior to Emacs 27 `string-match' has issues handling
multibyte regular expressions. As the compatibility function
for `string-search' is implemented via `string-match', these
issues are inherited."
(when (and start-pos (or (< (length haystack) start-pos)
(< start-pos 0)))
(signal 'args-out-of-range (list start-pos)))
(save-match-data
(let ((case-fold-search nil))
(string-match (regexp-quote needle) haystack start-pos))))
(compat-defun length= (sequence length)
"Returns non-nil if SEQUENCE has a length equal to LENGTH."
(cond
((null sequence) (zerop length))
((consp sequence)
(and (null (nthcdr length sequence))
(nthcdr (1- length) sequence)
t))
((arrayp sequence)
(= (length sequence) length))
((signal 'wrong-type-argument sequence))))
(compat-defun length< (sequence length)
"Returns non-nil if SEQUENCE is shorter than LENGTH."
(cond
((null sequence) (not (zerop length)))
((listp sequence)
(null (nthcdr (1- length) sequence)))
((arrayp sequence)
(< (length sequence) length))
((signal 'wrong-type-argument sequence))))
(compat-defun length> (sequence length)
"Returns non-nil if SEQUENCE is longer than LENGTH."
(cond
((listp sequence)
(and (nthcdr length sequence) t))
((arrayp sequence)
(> (length sequence) length))
((signal 'wrong-type-argument sequence))))
;;;; Defined in fileio.c
(compat-defun file-name-concat (directory &rest components)
"Append COMPONENTS to DIRECTORY and return the resulting string.
Elements in COMPONENTS must be a string or nil.
DIRECTORY or the non-final elements in COMPONENTS may or may not end
with a slash -- if they don’t end with a slash, a slash will be
inserted before contatenating."
(let ((seperator (eval-when-compile
(if (memq system-type '(ms-dos windows-nt cygwin))
"\\" "/")))
(last (if components (car (last components)) directory)))
(mapconcat (lambda (part)
(if (eq part last) ;the last component is not modified
last
(replace-regexp-in-string
(concat seperator "+\\'") "" part)))
(cons directory components)
seperator)))
;;;; Defined in alloc.c
;;* UNTESTED (but also not necessary)
(compat-defun garbage-collect-maybe (_factor)
"Call ‘garbage-collect’ if enough allocation happened.
FACTOR determines what \"enough\" means here: If FACTOR is a
positive number N, it means to run GC if more than 1/Nth of the
allocations needed to trigger automatic allocation took place.
Therefore, as N gets higher, this is more likely to perform a GC.
Returns non-nil if GC happened, and nil otherwise."
:note "For releases of Emacs before version 28, this function will do nothing."
;; Do nothing
nil)
;;;; Defined in filelock.c
(compat-defun unlock-buffer ()
"Handle `file-error' conditions:
Handles file system errors by calling ‘display-warning’ and
continuing as if the error did not occur."
:prefix t
(condition-case error
(unlock-buffer)
(file-error
(display-warning
'(unlock-file)
(message "%s, ignored" (error-message-string error))
:warning))))
;;;; Defined in characters.c
(compat-defun string-width (string &optional from to)
"Handle optional arguments FROM and TO:
Optional arguments FROM and TO specify the substring of STRING to
consider, and are interpreted as in `substring'."
:prefix t
(let* ((len (length string))
(from (or from 0))
(to (or to len)))
(if (and (= from 0) (= to len))
(string-width string)
(string-width (substring string from to)))))
;;;; Defined in dired.c
;;* UNTESTED
(compat-defun directory-files (directory &optional full match nosort count)
"Handle additional optional argument COUNT:
If COUNT is non-nil and a natural number, the function will
return COUNT number of file names (if so many are present)."
:prefix t
(let ((files (directory-files directory full match nosort)))
(when (natnump count)
(setf (nthcdr count files) nil))
files))
;;;; Defined in json.c
(declare-function json-insert nil (object &rest args))
(declare-function json-serialize nil (object &rest args))
(declare-function json-parse-string nil (string &rest args))
(declare-function json-parse-buffer nil (&rest args))
(compat-defun json-serialize (object &rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (or (listp object) (vectorp object))
(apply #'json-serialize object args)
(substring (json-serialize (list object)) 1 -1)))
(compat-defun json-insert (object &rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (or (listp object) (vectorp object))
(apply #'json-insert object args)
;; `compat-json-serialize' is not sharp-quoted as the byte
;; compiled doesn't always know that the function has been
;; defined, but it will only be used in this function if the
;; prefixed definition of `json-serialize' (see above) has also
;; been defined.
(insert (apply 'compat-json-serialize object args))))
(compat-defun json-parse-string (string &rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (string-match-p "\\`[[:space:]]*[[{]" string)
(apply #'json-parse-string string args)
;; Wrap the string in an array, and extract the value back using
;; `elt', to ensure that no matter what the value of `:array-type'
;; is we can access the first element.
(elt (apply #'json-parse-string (concat "[" string "]") args) 0)))
(compat-defun json-parse-buffer (&rest args)
"Handle top-level JSON values."
:prefix t
:min-version "27"
(if (looking-at-p "[[:space:]]*[[{]")
(apply #'json-parse-buffer args)
(catch 'escape
(atomic-change-group
(with-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?\" "\"" st)
(modify-syntax-entry ?. "_" st)
st)
(let ((inhibit-read-only t))
(save-excursion
(insert "[")
(forward-sexp 1)
(insert "]"))))
(throw 'escape (elt (apply #'json-parse-buffer args) 0))))))
;;;; xfaces.c
(compat-defun color-values-from-color-spec (spec)
"Parse color SPEC as a numeric color and return (RED GREEN BLUE).
This function recognises the following formats for SPEC:
#RGB, where R, G and B are hex numbers of equal length, 1-4 digits each.
rgb:R/G/B, where R, G, and B are hex numbers, 1-4 digits each.
rgbi:R/G/B, where R, G and B are floating-point numbers in [0,1].
If SPEC is not in one of the above forms, return nil.
Each of the 3 integer members of the resulting list, RED, GREEN,
and BLUE, is normalized to have its value in [0,65535]."
(let ((case-fold-search nil))
(save-match-data
(cond
((string-match
;; (rx bos "#"
;; (or (: (group-n 1 (= 1 hex)) (group-n 2 (= 1 hex)) (group-n 3 (= 1 hex)))
;; (: (group-n 1 (= 2 hex)) (group-n 2 (= 2 hex)) (group-n 3 (= 2 hex)))
;; (: (group-n 1 (= 3 hex)) (group-n 2 (= 3 hex)) (group-n 3 (= 3 hex)))
;; (: (group-n 1 (= 4 hex)) (group-n 2 (= 4 hex)) (group-n 3 (= 4 hex))))
;; eos)
"\\`#\\(?:\\(?1:[[:xdigit:]]\\{1\\}\\)\\(?2:[[:xdigit:]]\\{1\\}\\)\\(?3:[[:xdigit:]]\\{1\\}\\)\\|\\(?1:[[:xdigit:]]\\{2\\}\\)\\(?2:[[:xdigit:]]\\{2\\}\\)\\(?3:[[:xdigit:]]\\{2\\}\\)\\|\\(?1:[[:xdigit:]]\\{3\\}\\)\\(?2:[[:xdigit:]]\\{3\\}\\)\\(?3:[[:xdigit:]]\\{3\\}\\)\\|\\(?1:[[:xdigit:]]\\{4\\}\\)\\(?2:[[:xdigit:]]\\{4\\}\\)\\(?3:[[:xdigit:]]\\{4\\}\\)\\)\\'"
spec)
(let ((max (1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4)))))
(list (/ (* (string-to-number (match-string 1 spec) 16) 65535) max)
(/ (* (string-to-number (match-string 2 spec) 16) 65535) max)
(/ (* (string-to-number (match-string 3 spec) 16) 65535) max))))
((string-match
;; (rx bos "rgb:"
;; (group (** 1 4 hex)) "/"
;; (group (** 1 4 hex)) "/"
;; (group (** 1 4 hex))
;; eos)
"\\`rgb:\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)\\'"
spec)
(list (/ (* (string-to-number (match-string 1 spec) 16) 65535)
(1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4))))
(/ (* (string-to-number (match-string 2 spec) 16) 65535)
(1- (ash 1 (* (- (match-end 2) (match-beginning 2)) 4))))
(/ (* (string-to-number (match-string 3 spec) 16) 65535)
(1- (ash 1 (* (- (match-end 3) (match-beginning 3)) 4))))))
;; The "RGBi" (RGB Intensity) specification is defined by
;; XCMS[0], see [1] for the implementation in Xlib.
;;
;; [0] http://www.nic.funet.fi/pub/X11/X11R4/DOCS/color/Xcms.text
;; [1] https://gitlab.freedesktop.org/xorg/lib/libx11/-/blob/master/src/xcms/LRGB.c#L1392
((string-match
;; (rx bos "rgbi:" (* space)
;; (group (? (or "-" "+"))
;; (or (: (+ digit) (? "." (* digit)))
;; (: "." (+ digit)))
;; (? "e" (? (or "-" "+")) (+ digit)))
;; "/" (* space)
;; (group (? (or "-" "+"))
;; (or (: (+ digit) (? "." (* digit)))
;; (: "." (+ digit)))
;; (? "e" (? (or "-" "+")) (+ digit)))
;; "/" (* space)
;; (group (? (or "-" "+"))
;; (or (: (+ digit) (? "." (* digit)))
;; (: "." (+ digit)))
;; (? "e" (? (or "-" "+")) (+ digit)))
;; eos)
"\\`rgbi:[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)/[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)/[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)\\'"
spec)
(let ((r (round (* (string-to-number (match-string 1 spec)) 65535)))
(g (round (* (string-to-number (match-string 2 spec)) 65535)))
(b (round (* (string-to-number (match-string 3 spec)) 65535))))
(when (and (<= 0 r) (<= r 65535)
(<= 0 g) (<= g 65535)
(<= 0 b) (<= b 65535))
(list r g b))))))))
;;;; Defined in subr.el
;;* INCOMPLETE FEATURE: Should handle multibyte regular expressions
(compat-defun string-replace (fromstring tostring instring)
"Replace FROMSTRING with TOSTRING in INSTRING each time it occurs."
(when (equal fromstring "")
(signal 'wrong-length-argument '(0)))
(let ((case-fold-search nil))
(replace-regexp-in-string
(regexp-quote fromstring)
tostring instring
t t)))
(compat-defun always (&rest _arguments)
"Do nothing and return t.
This function accepts any number of ARGUMENTS, but ignores them.
Also see `ignore'."
t)
;;* UNTESTED
(compat-defun insert-into-buffer (buffer &optional start end)
"Insert the contents of the current buffer into BUFFER.
If START/END, only insert that region from the current buffer.
Point in BUFFER will be placed after the inserted text."
(let ((current (current-buffer)))
(with-current-buffer buffer
(insert-buffer-substring current start end))))
;;* UNTESTED
(compat-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))))
;;* UNTESTED
(compat-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))))
;;* UNTESTED
(compat-defun buffer-local-boundp (symbol buffer)
"Return non-nil if SYMBOL is bound in BUFFER.
Also see `local-variable-p'."
(catch 'fail
(condition-case nil
(buffer-local-value symbol buffer)
(void-variable nil (throw 'fail nil)))
t))
;;* UNTESTED
(compat-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 ((quit (make-symbol "with-existing-directory-quit")))
`(catch ',quit
(dolist (dir (list default-directory
(expand-file-name "~/")
(getenv "TMPDIR")
"/tmp/"
;; XXX: check if "/" works on non-POSIX
;; system.
"/"))
(when (and dir (file-exists-p dir))
(throw ',quit (let ((default-directory dir))
,@body)))))))
;;* UNTESTED
(compat-defmacro dlet (binders &rest body)
"Like `let' but using dynamic scoping."
(declare (indent 1) (debug let))
`(let (_)
,@(mapcar (lambda (binder)
`(defvar ,(if (consp binder) (car binder) binder)))
binders)
(let ,binders ,@body)))
(compat-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)))
(compat-defun subr-primitive-p (object)
"Return t if OBJECT is a built-in primitive function."
(subrp object))
;;;; Defined in subr-x.el
(compat-defun string-clean-whitespace (string)
"Clean up whitespace in STRING.
All sequences of whitespaces in STRING are collapsed into a
single space character, and leading/trailing whitespace is
removed."
:feature 'subr-x
(let ((blank "[[:blank:]\r\n]+"))
(replace-regexp-in-string
"^[[:blank:]\r\n]+\\|[[:blank:]\r\n]+$"
""
(replace-regexp-in-string
blank " " string))))
(compat-defun string-fill (string length)
"Clean up whitespace in STRING.
All sequences of whitespaces in STRING are collapsed into a
single space character, and leading/trailing whitespace is
removed."
:feature 'subr-x
(with-temp-buffer
(insert string)
(goto-char (point-min))
(let ((fill-column length)
(adaptive-fill-mode nil))
(fill-region (point-min) (point-max)))
(buffer-string)))
(compat-defun string-lines (string &optional omit-nulls)
"Split STRING into a list of lines.
If OMIT-NULLS, empty lines will be removed from the results."
:feature 'subr-x
(split-string string "\n" omit-nulls))
(compat-defun string-pad (string length &optional padding start)
"Pad STRING to LENGTH using PADDING.
If PADDING is nil, the space character is used. If not nil, it
should be a character.
If STRING is longer than the absolute value of LENGTH, no padding
is done.
If START is nil (or not present), the padding is done to the end
of the string, and if non-nil, padding is done to the start of
the string."
:feature 'subr-x
(unless (natnump length)
(signal 'wrong-type-argument (list 'natnump length)))
(let ((pad-length (- length (length string))))
(if (< pad-length 0)
string
(concat (and start
(make-string pad-length (or padding ?\s)))
string
(and (not start)
(make-string pad-length (or padding ?\s)))))))
(compat-defun string-chop-newline (string)
"Remove the final newline (if any) from STRING."
:feature 'subr-x
(if (and (>= (length string) 1) (= (aref string (1- (length string))) ?\n))
(substring string 0 -1)
string))
(compat-defmacro named-let (name bindings &rest body)
"Looping construct taken from Scheme.
Like `let', bind variables in BINDINGS and then evaluate BODY,
but with the twist that BODY can evaluate itself recursively by
calling NAME, where the arguments passed to NAME are used
as the new values of the bound variables in the recursive invocation."
:feature 'subr-x
(declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
(let ((fargs (mapcar (lambda (b)
(let ((var (if (consp b) (car b) b)))
(make-symbol (symbol-name var))))
bindings))
(aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings))
rargs)
(dotimes (i (length bindings))
(let ((b (nth i bindings)))
(push (list (if (consp b) (car b) b) (nth i fargs))
rargs)
(setf (if (consp b) (car b) b)
(nth i fargs))))
(letrec
((quit (make-symbol "quit")) (self (make-symbol "self"))
(total-tco t)
(macro (lambda (&rest args)
(setq total-tco nil)
`(funcall ,self . ,args)))
;; Based on `cl--self-tco':
(tco-progn (lambda (exprs)
(append
(butlast exprs)
(list (funcall tco (car (last exprs)))))))
(tco (lambda (expr)
(cond
((eq (car-safe expr) 'if)
(append (list 'if
(cadr expr)
(funcall tco (nth 2 expr)))
(funcall tco-progn (nthcdr 3 expr))))
((eq (car-safe expr) 'cond)
(let ((conds (cdr expr)) body)
(while conds
(let ((branch (pop conds)))
(push (cond
((cdr branch) ;has tail
(funcall tco-progn branch))
((null conds) ;last element
(list t (funcall tco (car branch))))
((progn
branch)))
body)))
(cons 'cond (nreverse body))))
((eq (car-safe expr) 'or)
(if (cddr expr)
(let ((var (make-symbol "var")))
`(let ((,var ,(cadr expr)))
(if ,var ,(funcall tco var)
,(funcall tco (cons 'or (cddr expr))))))
(funcall tco (cadr expr))))
((eq (car-safe expr) 'condition-case)
(append (list 'condition-case (cadr expr) (nth 2 expr))
(mapcar
(lambda (handler)
(cons (car handler)
(funcall tco-progn (cdr handler))))
(nthcdr 3 expr))))
((memq (car-safe expr) '(and progn))
(cons (car expr) (funcall tco-progn (cdr expr))))
((memq (car-safe expr) '(let let*))
(append (list (car expr) (cadr expr))
(funcall tco-progn (cddr expr))))
((eq (car-safe expr) name)
(let (sets (args (cdr expr)))
(dolist (farg fargs)
(push (list farg (pop args))
sets))
(cons 'setq (apply #'nconc (nreverse sets)))))
(`(throw ',quit ,expr))))))
(let ((tco-body (funcall tco (macroexpand-all (macroexp-progn body)))))
(when tco-body
(setq body `((catch ',quit
(while t (let ,rargs ,@(macroexp-unprogn tco-body))))))))
(let ((expand (macroexpand-all (macroexp-progn body) (list (cons name macro)))))
(if total-tco
`(let ,bindings ,expand)
`(funcall
(letrec ((,self (lambda ,fargs ,expand))) ,self)
,@aargs))))))
;;;; Defined in files.el
(declare-function compat--string-trim-left "compat-26" (string &optional regexp))
(declare-function compat--directory-name-p "compat-25" (name))
(compat-defun file-name-with-extension (filename extension)
"Set the EXTENSION of a FILENAME.
The extension (in a file name) is the part that begins with the last \".\".
Trims a leading dot from the EXTENSION so that either \"foo\" or
\".foo\" can be given.
Errors if the FILENAME or EXTENSION are empty, or if the given
FILENAME has the format of a directory.
See also `file-name-sans-extension'."
(let ((extn (compat--string-trim-left extension "[.]")))
(cond
((string= filename "")
(error "Empty filename"))
((string= extn "")
(error "Malformed extension: %s" extension))
((compat--directory-name-p filename)
(error "Filename is a directory: %s" filename))
(t
(concat (file-name-sans-extension filename) "." extn)))))
;;* UNTESTED
(compat-defun directory-empty-p (dir)
"Return t if DIR names an existing directory containing no other files.
Return nil if DIR does not name a directory, or if there was
trouble determining whether DIR is a directory or empty.
Symbolic links to directories count as directories.
See `file-symlink-p' to distinguish symlinks."
(and (file-directory-p dir)
(null (directory-files dir nil directory-files-no-dot-files-regexp t))))
(compat-defun file-modes-number-to-symbolic (mode &optional filetype)
"Return a string describing a file's MODE.
For instance, if MODE is #o700, then it produces `-rwx------'.
FILETYPE if provided should be a character denoting the type of file,
such as `?d' for a directory, or `?l' for a symbolic link and will override
the leading `-' char."
(string
(or filetype
(pcase (lsh mode -12)
;; POSIX specifies that the file type is included in st_mode
;; and provides names for the file types but values only for
;; the permissions (e.g., S_IWOTH=2).
;; (#o017 ??) ;; #define S_IFMT 00170000
(#o014 ?s) ;; #define S_IFSOCK 0140000
(#o012 ?l) ;; #define S_IFLNK 0120000
;; (8 ??) ;; #define S_IFREG 0100000
(#o006 ?b) ;; #define S_IFBLK 0060000
(#o004 ?d) ;; #define S_IFDIR 0040000
(#o002 ?c) ;; #define S_IFCHR 0020000
(#o001 ?p) ;; #define S_IFIFO 0010000
(_ ?-)))
(if (zerop (logand 256 mode)) ?- ?r)
(if (zerop (logand 128 mode)) ?- ?w)
(if (zerop (logand 64 mode))
(if (zerop (logand 2048 mode)) ?- ?S)
(if (zerop (logand 2048 mode)) ?x ?s))
(if (zerop (logand 32 mode)) ?- ?r)
(if (zerop (logand 16 mode)) ?- ?w)
(if (zerop (logand 8 mode))
(if (zerop (logand 1024 mode)) ?- ?S)
(if (zerop (logand 1024 mode)) ?x ?s))
(if (zerop (logand 4 mode)) ?- ?r)
(if (zerop (logand 2 mode)) ?- ?w)
(if (zerop (logand 512 mode))
(if (zerop (logand 1 mode)) ?- ?x)
(if (zerop (logand 1 mode)) ?T ?t))))
;;* UNTESTED
(compat-defun file-backup-file-names (filename)
"Return a list of backup files for FILENAME.
The list will be sorted by modification time so that the most
recent files are first."
;; `make-backup-file-name' will get us the right directory for
;; ordinary or numeric backups. It might create a directory for
;; backups as a side-effect, according to `backup-directory-alist'.
(let* ((filename (file-name-sans-versions
(make-backup-file-name (expand-file-name filename))))
(dir (file-name-directory filename))
files)
(dolist (file (file-name-all-completions
(file-name-nondirectory filename) dir))
(let ((candidate (concat dir file)))
(when (and (backup-file-name-p candidate)
(string= (file-name-sans-versions candidate) filename))
(push candidate files))))
(sort files #'file-newer-than-file-p)))
(compat-defun make-lock-file-name (filename)
"Make a lock file name for FILENAME.
This prepends \".#\" to the non-directory part of FILENAME, and
doesn't respect `lock-file-name-transforms', as Emacs 28.1 and
onwards does."
(expand-file-name
(concat
".#" (file-name-nondirectory filename))
(file-name-directory filename)))
;;;; Defined in files-x.el
(declare-function tramp-tramp-file-p "tramp" (name))
;;* UNTESTED
(compat-defun null-device ()
"Return the best guess for the null device."
(require 'tramp)
(if (tramp-tramp-file-p default-directory)
"/dev/null"
null-device))
;;;; Defined in minibuffer.el
(compat-defun format-prompt (prompt default &rest format-args)
"Format PROMPT with DEFAULT.
If FORMAT-ARGS is nil, PROMPT is used as a plain string. If
FORMAT-ARGS is non-nil, PROMPT is used as a format control
string, and FORMAT-ARGS are the arguments to be substituted into
it. See `format' for details.
If DEFAULT is a list, the first element is used as the default.
If not, the element is used as is.
If DEFAULT is nil or an empty string, no \"default value\" string
is included in the return value."
(concat
(if (null format-args)
prompt
(apply #'format prompt format-args))
(and default
(or (not (stringp default))
(> (length default) 0))
(format " (default %s)"
(if (consp default)
(car default)
default)))
": "))
;;;; Defined in windows.el
;;* UNTESTED
(compat-defun count-windows (&optional minibuf all-frames)
"Handle optional argument ALL-FRAMES:
If ALL-FRAMES is non-nil, count the windows in all frames instead
just the selected frame."
:prefix t
(if all-frames
(let ((sum 0))
(dolist (frame (frame-list))
(with-selected-frame frame
(setq sum (+ (count-windows minibuf) sum))))
sum)
(count-windows minibuf)))
;;;; Defined in thingatpt.el
(declare-function mouse-set-point "mouse" (event &optional promote-to-region))
;;* UNTESTED
(compat-defun thing-at-mouse (event thing &optional no-properties)
"Return the THING at mouse click.
Like `thing-at-point', but tries to use the event
where the mouse button is clicked to find a thing nearby."
:feature 'thingatpt
(save-excursion
(mouse-set-point event)
(thing-at-point thing no-properties)))
;;;; Defined in macroexp.el
;;* UNTESTED
(compat-defun macroexp-file-name ()
"Return the name of the file from which the code comes.
Returns nil when we do not know.
A non-nil result is expected to be reliable when called from a macro in order
to find the file in which the macro's call was found, and it should be
reliable as well when used at the top-level of a file.
Other uses risk returning non-nil value that point to the wrong file."
:feature 'macroexp
(let ((file (car (last current-load-list))))
(or (if (stringp file) file)
(bound-and-true-p byte-compile-current-file))))
;;;; Defined in env.el
;;* UNTESTED
(compat-defmacro with-environment-variables (variables &rest body)
"Set VARIABLES in the environent and execute BODY.
VARIABLES is a list of variable settings of the form (VAR VALUE),
where VAR is the name of the variable (a string) and VALUE
is its value (also a string).
The previous values will be be restored upon exit."
(declare (indent 1) (debug (sexp body)))
(unless (consp variables)
(error "Invalid VARIABLES: %s" variables))
`(let ((process-environment (copy-sequence process-environment)))
,@(mapcar (lambda (elem)
`(setenv ,(car elem) ,(cadr elem)))
variables)
,@body))
;;;; Defined in button.el
;;* UNTESTED
(compat-defun button-buttonize (string callback &optional data)
"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."
:feature 'button
(propertize string
'face 'button
'button t
'follow-link t
'category t
'button-data data
'keymap button-map
'action callback))
;;;; Defined in autoload.el
(defvar generated-autoload-file)
;;* UNTESTED
(compat-defun make-directory-autoloads (dir output-file)
"Update autoload definitions for Lisp files in the directories DIRS.
DIR can be either a single directory or a list of
directories. (The latter usage is discouraged.)
The autoloads will be written to OUTPUT-FILE. If any Lisp file
binds `generated-autoload-file' as a file-local variable, write
its autoloads into the specified file instead.
The function does NOT recursively descend into subdirectories of the
directory or directories specified."
(let ((generated-autoload-file output-file))
;; We intentionally don't sharp-quote
;; `update-directory-autoloads', because it was deprecated in
;; Emacs 28 and we don't want to trigger the byte compiler for
;; newer versions.
(apply 'update-directory-autoloads
(if (listp dir) dir (list dir)))))
;;;; Defined in time-data.el
(compat-defun decoded-time-period (time)
"Interpret DECODED as a period and return its length in seconds.
For computational purposes, years are 365 days long and months
are 30 days long."
:feature 'time-date
:version "28"
;; Inlining the definitions from compat-27
(+ (if (consp (nth 0 time))
;; Fractional second.
(/ (float (car (nth 0 time)))
(cdr (nth 0 time)))
(or (nth 0 time) 0))
(* (or (nth 1 time) 0) 60)
(* (or (nth 2 time) 0) 60 60)
(* (or (nth 3 time) 0) 60 60 24)
(* (or (nth 4 time) 0) 60 60 24 30)
(* (or (nth 5 time) 0) 60 60 24 365)))
(compat--inhibit-prefixed (provide 'compat-28))
;;; compat-28.el ends here

48
lisp/compat/compat-font-lock.el Normal file
View File

@@ -0,0 +1,48 @@
;;; compat-font-lock.el --- -*- lexical-binding: t; -*-
;; Copyright (C) 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Keywords:
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Optional font-locking for `compat' definitions. Every symbol with
;; an active compatibility definition will be highlighted.
;;
;; Load this file to enable the functionality.
;;; Code:
(eval-and-compile
(require 'cl-lib)
(require 'compat-macs))
(defvar compat-generate-common-fn)
(let ((compat-generate-common-fn
(lambda (name _def-fn _install-fn check-fn attr _type)
(unless (and (plist-get attr :no-highlight)
(funcall check-fn))
`(font-lock-add-keywords
'emacs-lisp-mode
',`((,(concat "\\_<\\("
(regexp-quote (symbol-name name))
"\\)\\_>")
1 font-lock-preprocessor-face prepend)))))))
(load "compat"))
(provide 'compat-font-lock)
;;; compat-font-lock.el ends here

57
lisp/compat/compat-help.el Normal file
View File

@@ -0,0 +1,57 @@
;;; compat-help.el --- Documentation for compat functions -*- lexical-binding: t; -*-
;; Copyright (C) 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Load this file to insert `compat'-relevant documentation next to
;; the regular documentation of a symbol.
;;; Code:
(defun compat---describe (symbol)
"Insert documentation for SYMBOL if it has compatibility code."
(let ((compat (get symbol 'compat-def)))
(when compat
(let ((doc (get compat 'compat-doc))
(start (point)))
(when doc
(insert "There is a ")
(insert-button
"compatibility notice"
'action (let ((type (get compat 'compat-type)))
(cond
((memq type '(func macro advice))
#'find-function)
((memq type '(variable))
#'find-variable)
((error "Unknown type"))))
'button-data compat)
(insert (format " for %s (for versions of Emacs before %s):"
(symbol-name symbol)
(get compat 'compat-version)))
(add-text-properties start (point) '(face bold))
(newline 2)
(insert (substitute-command-keys doc))
(fill-region start (point))
(newline 2))))))
(add-hook 'help-fns-describe-function-functions #'compat---describe)
(provide 'compat-help)
;;; compat-help.el ends here

316
lisp/compat/compat-macs.el Normal file
View File

@@ -0,0 +1,316 @@
;;; compat-macs.el --- Compatibility Macros -*- lexical-binding: t; no-byte-compile: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Keywords: lisp
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; These macros are used to define compatibility functions, macros and
;; advice.
;;; Code:
(defmacro compat--ignore (&rest _)
"Ignore all arguments."
nil)
(defvar compat--inhibit-prefixed nil
"Non-nil means that prefixed definitions are not loaded.
A prefixed function is something like `compat-assoc', that is
only made visible when the respective compatibility version file
is loaded (in this case `compat-26').")
(defmacro compat--inhibit-prefixed (&rest body)
"Ignore BODY unless `compat--inhibit-prefixed' is true."
`(unless (bound-and-true-p compat--inhibit-prefixed)
,@body))
(defvar compat-current-version nil
"Default version to use when no explicit version was given.")
(defmacro compat-declare-version (version)
"Set the Emacs version that is currently being handled to VERSION."
;; FIXME: Avoid setting the version for any definition that might
;; follow, but try to restrict it to the current file/buffer.
(setq compat-current-version version)
nil)
(defvar compat--generate-function #'compat--generate-default
"Function used to generate compatibility code.
The function must take six arguments: NAME, DEF-FN, INSTALL-FN,
CHECK-FN, ATTR and TYPE. The resulting body is constructed by
invoking the functions DEF-FN (passed the \"realname\" and the
version number, returning the compatibility definition), the
INSTALL-FN (passed the \"realname\" and returning the
installation code), CHECK-FN (passed the \"realname\" and
returning a check to see if the compatibility definition should
be installed). ATTR is a plist used to modify the generated
code. The following attributes are handled, all others are
ignored:
- :min-version :: Prevent the compatibility definition from begin
installed in versions older than indicated (string).
- :max-version :: Prevent the compatibility definition from begin
installed in versions newer than indicated (string).
- :feature :: The library the code is supposed to be loaded
with (via `eval-after-load').
- :cond :: Only install the compatibility code, iff the value
evaluates to non-nil.
For prefixed functions, this can be interpreted as a test to
`defalias' an existing definition or not.
- :no-highlight :: Do not highlight this definition as
compatibility function.
- :version :: Manual specification of the version the compatee
code was defined in (string).
- :realname :: Manual specification of a \"realname\" to use for
the compatibility definition (symbol).
- :notes :: Additional notes that a developer using this
compatibility function should keep in mind.
- :prefix :: Add a `compat-' prefix to the name, and define the
compatibility code unconditionally.
TYPE is used to set the symbol property `compat-type' for NAME.")
(defun compat--generate-default (name def-fn install-fn check-fn attr type)
"Generate a leaner compatibility definition.
See `compat-generate-function' for details on the arguments NAME,
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
(let* ((min-version (plist-get attr :min-version))
(max-version (plist-get attr :max-version))
(feature (plist-get attr :feature))
(cond (plist-get attr :cond))
(version (or (plist-get attr :version)
compat-current-version))
(realname (or (plist-get attr :realname)
(intern (format "compat--%S" name))))
(check (cond
((or (and min-version
(version< emacs-version min-version))
(and max-version
(version< max-version emacs-version)))
'(compat--ignore))
((plist-get attr :prefix)
'(compat--inhibit-prefixed))
((and version (version<= version emacs-version) (not cond))
'(compat--ignore))
(`(when (and ,(if cond cond t)
,(funcall check-fn)))))))
(cond
((and (plist-get attr :prefix) (memq type '(func macro))
(string-match "\\`compat-\\(.+\\)\\'" (symbol-name name))
(let* ((actual-name (intern (match-string 1 (symbol-name name))))
(body (funcall install-fn actual-name version)))
(when (and (version<= version emacs-version)
(fboundp actual-name))
`(,@check
,(if feature
;; See https://nullprogram.com/blog/2018/02/22/:
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
body))))))
((plist-get attr :realname)
`(progn
,(funcall def-fn realname version)
(,@check
,(let ((body (funcall install-fn realname version)))
(if feature
;; See https://nullprogram.com/blog/2018/02/22/:
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
body)))))
((let* ((body (if (eq type 'advice)
`(,@check
,(funcall def-fn realname version)
,(funcall install-fn realname version))
`(,@check ,(funcall def-fn name version)))))
(if feature
;; See https://nullprogram.com/blog/2018/02/22/:
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
body))))))
(defun compat-generate-common (name def-fn install-fn check-fn attr type)
"Common code for generating compatibility definitions.
See `compat-generate-function' for details on the arguments NAME,
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
(when (and (plist-get attr :cond) (plist-get attr :prefix))
(error "A prefixed function %s cannot have a condition" name))
(funcall compat--generate-function
name def-fn install-fn check-fn attr type))
(defun compat-common-fdefine (type name arglist docstring rest)
"Generate compatibility code for a function NAME.
TYPE is one of `func', for functions and `macro' for macros, and
`advice' ARGLIST is passed on directly to the definition, and
DOCSTRING is prepended with a compatibility note. REST contains
the remaining definition, that may begin with a property list of
attributes (see `compat-generate-common')."
(let ((oldname name) (body rest))
(while (keywordp (car body))
(setq body (cddr body)))
;; It might be possible to set these properties otherwise. That
;; should be looked into and implemented if it is the case.
(when (and (listp (car-safe body)) (eq (caar body) 'declare))
(when (version<= emacs-version "25")
(delq (assq 'side-effect-free (car body)) (car body))
(delq (assq 'pure (car body)) (car body))))
;; Check if we want an explicitly prefixed function
(when (plist-get rest :prefix)
(setq name (intern (format "compat-%s" name))))
(compat-generate-common
name
(lambda (realname version)
`(,(cond
((memq type '(func advice)) 'defun)
((eq type 'macro) 'defmacro)
((error "Unknown type")))
,realname ,arglist
;; Prepend compatibility notice to the actual
;; documentation string.
,(let ((type (cond
((eq type 'func) "function")
((eq type 'macro) "macro")
((eq type 'advice) "advice")
((error "Unknown type")))))
(if version
(format
"[Compatibility %s for `%S', defined in Emacs %s]\n\n%s"
type oldname version docstring)
(format
"[Compatibility %s for `%S']\n\n%s"
type oldname docstring)))
;; Advice may use the implicit variable `oldfun', but
;; to avoid triggering the byte compiler, we make
;; sure the argument is used at least once.
,@(if (eq type 'advice)
(cons '(ignore oldfun) body)
body)))
(lambda (realname _version)
(cond
((memq type '(func macro))
;; Functions and macros are installed by
;; aliasing the name of the compatible
;; function to the name of the compatibility
;; function.
`(defalias ',name #',realname))
((eq type 'advice)
`(advice-add ',name :around #',realname))))
(lambda ()
(cond
((memq type '(func macro))
`(not (fboundp ',name)))
((eq type 'advice) t)))
rest type)))
(defmacro compat-defun (name arglist docstring &rest rest)
"Define NAME with arguments ARGLIST as a compatibility function.
The function must be documented in DOCSTRING. REST may begin
with a plist, that is interpreted by the macro but not passed on
to the actual function. See `compat-generate-common' for a
listing of attributes.
The definition will only be installed, if the version this
function was defined in, as indicated by the `:version'
attribute, is greater than the current Emacs version."
(declare (debug (&define name (&rest symbolp)
stringp
[&rest keywordp sexp]
def-body))
(doc-string 3) (indent 2))
(compat-common-fdefine 'func name arglist docstring rest))
(defmacro compat-defmacro (name arglist docstring &rest rest)
"Define NAME with arguments ARGLIST as a compatibility macro.
The macro must be documented in DOCSTRING. REST may begin
with a plist, that is interpreted by this macro but not passed on
to the actual macro. See `compat-generate-common' for a
listing of attributes.
The definition will only be installed, if the version this
function was defined in, as indicated by the `:version'
attribute, is greater than the current Emacs version."
(declare (debug compat-defun) (doc-string 3) (indent 2))
(compat-common-fdefine 'macro name arglist docstring rest))
(defmacro compat-advise (name arglist docstring &rest rest)
"Define NAME with arguments ARGLIST as a compatibility advice.
The advice function must be documented in DOCSTRING. REST may
begin with a plist, that is interpreted by this macro but not
passed on to the actual advice function. See
`compat-generate-common' for a listing of attributes. The advice
wraps the old definition, that is accessible via using the symbol
`oldfun'.
The advice will only be installed, if the version this function
was defined in, as indicated by the `:version' attribute, is
greater than the current Emacs version."
(declare (debug compat-defun) (doc-string 3) (indent 2))
(compat-common-fdefine 'advice name (cons 'oldfun arglist) docstring rest))
(defmacro compat-defvar (name initval docstring &rest attr)
"Declare compatibility variable NAME with initial value INITVAL.
The obligatory documentation string DOCSTRING must be given.
The remaining arguments ATTR form a plist, modifying the
behaviour of this macro. See `compat-generate-common' for a
listing of attributes. Furthermore, `compat-defvar' also handles
the attribute `:local' that either makes the variable permanent
local with a value of `permanent' or just buffer local with any
non-nil value."
(declare (debug (name form stringp [&rest keywordp sexp]))
(doc-string 3) (indent 2))
;; Check if we want an explicitly prefixed function
(let ((oldname name))
(when (plist-get attr :prefix)
(setq name (intern (format "compat-%s" name))))
(compat-generate-common
name
(lambda (realname version)
(let ((localp (plist-get attr :local)))
`(progn
(,(if (plist-get attr :constant) 'defconst 'defvar)
,realname ,initval
;; Prepend compatibility notice to the actual
;; documentation string.
,(if version
(format
"[Compatibility variable for `%S', defined in Emacs %s]\n\n%s"
oldname version docstring)
(format
"[Compatibility variable for `%S']\n\n%s"
oldname docstring)))
;; Make variable as local if necessary
,(cond
((eq localp 'permanent)
`(put ',realname 'permanent-local t))
(localp
`(make-variable-buffer-local ',realname))))))
(lambda (realname _version)
`(defvaralias ',name ',realname))
(lambda ()
`(not (boundp ',name)))
attr 'variable)))
(provide 'compat-macs)
;;; compat-macs.el ends here

2
lisp/compat/compat-pkg.el Normal file
View File

@@ -0,0 +1,2 @@
;; Generated package description from compat.el -*- no-byte-compile: t -*-
(define-package "compat" "28.1.2.2" "Emacs Lisp Compatibility Library" '((emacs "24.3") (nadvice "0.3")) :commit "d533692182c084bad623977b69f9dc298255eaab" :authors '(("Philip Kaludercic" . "philipk@posteo.net")) :maintainer '("Compat Development" . "~pkal/compat-devel@lists.sr.ht") :keywords '("lisp") :url "https://sr.ht/~pkal/compat")

58
lisp/compat/compat.el Normal file
View File

@@ -0,0 +1,58 @@
;;; compat.el --- Emacs Lisp Compatibility Library -*- lexical-binding: t; -*-
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
;; Version: 28.1.2.2
;; URL: https://sr.ht/~pkal/compat
;; Package-Requires: ((emacs "24.3") (nadvice "0.3"))
;; Keywords: lisp
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; To allow for the usage of Emacs functions and macros that are
;; defined in newer versions of Emacs, compat.el provides definitions
;; that are installed ONLY if necessary. These reimplementations of
;; functions and macros are at least subsets of the actual
;; implementations. Be sure to read the documentation string to make
;; sure.
;;
;; Not every function provided in newer versions of Emacs is provided
;; here. Some depend on new features from the core, others cannot be
;; implemented to a meaningful degree. Please consult the Compat
;; manual for details. The main audience for this library are not
;; regular users, but package maintainers. Therefore commands and
;; user options are usually not implemented here.
;;; Code:
(defvar compat--inhibit-prefixed)
(let ((compat--inhibit-prefixed (not (bound-and-true-p compat-testing))))
;; Instead of using `require', we manually check `features' and call
;; `load' to avoid the issue of not using `provide' at the end of
;; the file (which is disabled by `compat--inhibit-prefixed', so
;; that the file can be loaded again at some later point when the
;; prefixed definitions are needed).
(dolist (vers '(24 25 26 27 28))
(unless (memq (intern (format "compat-%d" vers)) features)
(load (format "compat-%d%s" vers
(if (bound-and-true-p compat-testing)
".el" ""))
nil t))))
(provide 'compat)
;;; compat.el ends here

2071
lisp/compat/compat.info Normal file
View File

File diff suppressed because it is too large Load Diff

18
lisp/compat/dir Normal file
View File

@@ -0,0 +1,18 @@
This is the file .../info/dir, which contains the
topmost node of the Info hierarchy, called (dir)Top.
The first time you invoke Info you start off looking at this node.

File: dir, Node: Top This is the top of the INFO tree
This (the Directory node) gives a menu of major topics.
Typing "q" exits, "H" lists all Info commands, "d" returns here,
"h" gives a primer for first-timers,
"mEmacs<Return>" visits the Emacs manual, etc.
In Emacs, you can click mouse button 2 on a menu item or cross reference
to select it.
* Menu:
Emacs
* Compat: (compat). Compatibility Library for Emacs Lisp.