diff options
| -rw-r--r-- | .dir-locals.el | 3 | ||||
| -rw-r--r-- | .elpaignore | 1 | ||||
| -rw-r--r-- | .github/workflows/makefile.yml | 5 | ||||
| -rw-r--r-- | .gitignore | 3 | ||||
| -rw-r--r-- | Makefile | 37 | ||||
| -rw-r--r-- | NEWS.org | 88 | ||||
| -rw-r--r-- | README.md | 46 | ||||
| -rw-r--r-- | compat-24.4.el | 176 | ||||
| -rw-r--r-- | compat-24.el | 524 | ||||
| -rw-r--r-- | compat-25.el (renamed from compat-25.1.el) | 157 | ||||
| -rw-r--r-- | compat-26.1.el | 299 | ||||
| -rw-r--r-- | compat-26.el | 631 | ||||
| -rw-r--r-- | compat-27.el (renamed from compat-27.1.el) | 299 | ||||
| -rw-r--r-- | compat-28.el (renamed from compat-28.1.el) | 341 | ||||
| -rw-r--r-- | compat-29.el (renamed from compat-29.1.el) | 9 | ||||
| -rw-r--r-- | compat-font-lock.el | 48 | ||||
| -rw-r--r-- | compat-macs.el | 159 | ||||
| -rw-r--r-- | compat-tests.el | 2717 | ||||
| -rw-r--r-- | compat.el | 164 | ||||
| -rw-r--r-- | compat.texi | 1163 |
20 files changed, 4910 insertions, 1960 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 1f7c4b7..2ce32d6 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -1,4 +1,5 @@ ;;; Directory Local Variables ;;; For more information see (info "(emacs) Directory Variables") -((emacs-lisp-mode . ((indent-tabs-mode . nil)))) +((emacs-lisp-mode . ((show-trailing-whitespace . t) + (indent-tabs-mode . nil)))) diff --git a/.elpaignore b/.elpaignore index 0767134..2fe0af5 100644 --- a/.elpaignore +++ b/.elpaignore @@ -5,3 +5,4 @@ Makefile .elpaignore COPYING README.md +compat.texi diff --git a/.github/workflows/makefile.yml b/.github/workflows/makefile.yml index 21731ff..bf7c0f7 100644 --- a/.github/workflows/makefile.yml +++ b/.github/workflows/makefile.yml @@ -15,7 +15,7 @@ jobs: strategy: matrix: emacs-version: - - '24.3' + # - '24.3' - '24.4' - '24.5' - '25.1' @@ -26,6 +26,7 @@ jobs: - '26.3' - '27.1' - '27.2' + - '28.1' - 'snapshot' steps: - uses: actions/checkout@v2 @@ -33,4 +34,4 @@ jobs: with: version: ${{ matrix.emacs-version }} - name: Compile and run tests - run: make + run: make test @@ -2,4 +2,5 @@ *~ \#*\# /compat-pkg.el -/compat-autoloads.el
\ No newline at end of file +/compat-autoloads.el +/compat.info @@ -3,26 +3,39 @@ .SUFFIXES: .el .elc EMACS = emacs -BYTEC = compat-help.elc \ - compat-macs.elc \ - compat-24.4.elc \ - compat-25.1.elc \ - compat-26.1.elc \ - compat-27.1.elc \ - compat-28.1.elc \ - compat-29.1.elc \ +MAKEINFO = makeinfo +BYTEC = compat-macs.elc \ + compat-help.elc \ + compat-font-lock.elc \ + compat-24.elc \ + compat-25.elc \ + compat-26.elc \ + compat-27.elc \ + compat-28.elc \ + compat-29.elc \ compat.elc -all: compile test +all: compile compile: $(BYTEC) -test: +test: compile + $(EMACS) --version $(EMACS) -Q --batch -L . -l compat-tests.el -f ert-run-tests-batch-and-exit clean: - $(RM) $(BYTEC) + $(RM) $(BYTEC) compat.info + +compat-24.el: compat-macs.el +compat-25.el: compat-macs.el +compat-26.el: compat-macs.el +compat-27.el: compat-macs.el +compat-28.el: compat-macs.el +compat-29.el: compat-macs.el +compat-font-lock.el: compat-macs.el .el.elc: - $(EMACS) -Q --batch -L . -f batch-byte-compile $^ + $(EMACS) -Q --batch -L . -f batch-byte-compile $< +compat.info: compat.texi + $(MAKEINFO) $< diff --git a/NEWS.org b/NEWS.org new file mode 100644 index 0000000..9c6a819 --- /dev/null +++ b/NEWS.org @@ -0,0 +1,88 @@ +#+options: toc:nil num:nil +#+link: compat https://todo.sr.ht/~pkal/compat/ + +* 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>) + + @@ -1,10 +1,6 @@ COMPATibility Library for Emacs =============================== -> **Note to package developers:** compat.el hasn't yet been published, -> and should not yet be added as a dependency. The official release -> of the package will coincide with the release of Emacs 28.1. - Find here the source for compat.el, a forwards-compatibility library for (GNU) Emacs Lisp, versions 24.3 and newer. @@ -15,7 +11,7 @@ for users bound to specific Emacs releases. Version 24.3 is chosen as the oldest version, because this is the newest version on CentOS 7. It is intended to preserve compatibility -for at least as the Centos 7 reaches [EOL], 2024. +for at least as the CentOS 7 reaches [EOL], 2024. If you are developing a package with compat.el in mind, consider loading `compat-help` (on your system, not in a package) to get @@ -42,12 +38,22 @@ Usage The intended use-case for this library is for package developers to add as a dependency in the header: - ;; Package-Requires: ((emacs "24.3") (compat "28.1.0.0")) + ;; Package-Requires: ((emacs "24.3") (compat "28.1.2.0")) + +and later on a + + (require 'compat) + +This will load all non-prefixed definitions (functions and macros with +a leading `compat-`). To load these, an additional -No further action should be required afterwards. The effect should be -that all the functions and macros that compat.el provides are -automatically accessible or made accessible as soon as the right -libraries are loaded. + (require 'compat-XY) ; e.g. 26 + +will be necessary, to load compatibility code for Emacs version XY. + +It is recommended to subscribe to the [compat-announce] mailing list +to be notified when new versions are released or relevant changes are +made. Contribute ---------- @@ -59,18 +65,18 @@ contributions. Source code ----------- -The project is managed can be found on [SourceHut] but has a [GitHub] -mirror as well. +Compat is developed on [SourceHut]. A restricted [GitHub] mirror is +also provided. Bug and patches --------------- -Patches, bug reports and comments can be sent to the mailing list - - ~pkal/public-inbox@lists.sr.ht - -or via GitHub. These may include issues in the compatibility code, -missing definitions or performance issues. +Patches and comments can be sent to the [development mailing +list][compat-devel]. Bug reports and issues should be directed to the +[issue tracker][compat-tracker] (also accessible via +[Email][compat-tracker-mailto]). [GitHub] can also be used to submit +patches ("Pull Request"). These may include issues in the +compatibility code, missing definitions or performance issues. When contributing, make sure to provide test and use the existing tests defined in compat-test.el. These can be easily executed using @@ -89,3 +95,7 @@ the GPL, Version 3 (like Emacs itself). [copyright assignment]: https://www.gnu.org/software/emacs/manual/html_node/emacs/Copyright-Assignment.html [SourceHut]: https://sr.ht/~pkal/compat [GitHub]: https://github.com/phikal/compat.el +[compat-announce]: https://lists.sr.ht/~pkal/compat-announce +[compat-devel]: https://lists.sr.ht/~pkal/compat-devel +[compat-tracker]: https://todo.sr.ht/~pkal/compat +[compat-tracker-mailto]: mailto:~pkal/compat@todo.sr.ht diff --git a/compat-24.4.el b/compat-24.4.el deleted file mode 100644 index 338513f..0000000 --- a/compat-24.4.el +++ /dev/null @@ -1,176 +0,0 @@ -;;; compat-24.4.el --- Compatibility Layer for Emacs 24.4 -*- lexical-binding: t; -*- - -;; Copyright (C) 2021 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: - -;; Find here the functionality added in Emacs 24.4, needed by older -;; versions. -;; -;; Do NOT load this library manually. Instead require `compat'. - -;;; Code: - -(eval-when-compile (require 'compat-macs)) - -;;;; 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)) - -;;;; Defined in subr.el - -(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) - -(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)))) - -(provide 'compat-24.4) -;;; compat-24.4.el ends here diff --git a/compat-24.el b/compat-24.el new file mode 100644 index 0000000..f208ae7 --- /dev/null +++ b/compat-24.el @@ -0,0 +1,524 @@ +;;; 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: + +(eval-when-compile (require 'compat-macs)) + +;;;; Defined in data.c + +(compat-defun = (number-or-marker &rest numbers-or-markers) + "Handle multiple arguments." + :version "24.4" + :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." + :version "24.4" + :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." + :version "24.4" + :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." + :version "24.4" + :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." + :version "24.4" + :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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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'." + :version "24.4" + :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." + :version "24.4" + (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'." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + ;; 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." + :version "24.4" + (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." + :version "24.4" + (let (values) + (maphash + (lambda (_k v) (push v values)) + hash-table) + values)) + +(compat-defun string-empty-p (string) + "Check whether STRING is empty." + :version "24.4" + (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." + :version "24.4" + (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." + :version "24.4" + (string-match-p "\\`[ \t\n\r]*\\'" string)) + +(compat-defun string-remove-prefix (prefix string) + "Remove PREFIX from STRING if present." + :version "24.4" + (if (string-prefix-p prefix string) + (substring string (length prefix)) + string)) + +(compat-defun string-remove-suffix (suffix string) + "Remove SUFFIX from STRING if present." + :version "24.4" + (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." + :version "24.4" + (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 diff --git a/compat-25.1.el b/compat-25.el index 9d2859d..eb9d0a8 100644 --- a/compat-25.1.el +++ b/compat-25.el @@ -1,8 +1,10 @@ -;;; compat-25.1.el --- Compatibility Layer for Emacs 25.1 -*- lexical-binding: t; -*- +;;; compat-25.el --- Compatibility Layer for Emacs 25.1 -*- lexical-binding: t; -*- -;; Copyright (C) 2021 Free Software Foundation, Inc. +;; 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 @@ -23,12 +25,30 @@ ;; Find here the functionality added in Emacs 25.1, needed by older ;; versions. ;; -;; Do NOT load this library manually. Instead require `compat'. +;; Only load this library if you need to use one of the following +;; functions: +;; +;; - `compat-sort' ;;; Code: (eval-when-compile (require 'compat-macs)) +;;;; 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) @@ -62,6 +82,7 @@ This implementation is equivalent to `format'." (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)) ?\\ ?/)) @@ -75,6 +96,7 @@ 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'." @@ -108,53 +130,6 @@ Equality with KEY is tested by TESTFN, defaulting to `eq'." ;;;; Defined in subr-x.el -(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-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." - :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*)) - `(compat--if-let* ,varlist ,(macroexp-progn 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*)) - `(compat--when-let* ,varlist ,@(or body '(t)))) - (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 @@ -171,6 +146,7 @@ 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) @@ -180,7 +156,7 @@ with an old syntax that accepted only one binding." (not (listp (car spec)))) ;; Adjust the single binding case (setq spec (list spec))) - `(compat--if-let* ,spec ,then ,@(macroexp-unprogn else))) + `(compat--if-let* ,spec ,then ,(macroexp-progn else))) (compat-defmacro when-let (spec &rest body) "Bind variables according to SPEC and conditionally evaluate BODY. @@ -190,7 +166,7 @@ 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--if-let ,spec ,(macroexp-progn body))) (compat-defmacro thread-first (&rest forms) "Thread FORMS elements as the first argument of their successor. @@ -267,5 +243,78 @@ threading." form)))))))) (t form))) -(provide 'compat-25.1) -;;; compat-25.1.el ends here +;;;; 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 diff --git a/compat-26.1.el b/compat-26.1.el deleted file mode 100644 index d6b0d33..0000000 --- a/compat-26.1.el +++ /dev/null @@ -1,299 +0,0 @@ -;;; compat-26.1.el --- Compatibility Layer for Emacs 26.1 -*- lexical-binding: t; -*- - -;; Copyright (C) 2021 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: - -;; Find here the functionality added in Emacs 26.1, needed by older -;; versions. -;; -;; Do NOT load this library manually. Instead require `compat'. - -;;; Code: - -(eval-when-compile (require 'compat-macs)) -(declare-function compat-func-arity "compat" (func)) - -;;;; 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." - (compat-func-arity 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))) - -(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.1" - (key alist &optional default remove testfn)) -(compat-defun alist-get (key alist &optional default remove testfn) - "Handle TESTFN manually." - :min-version "25.1" ;first defined in 25.1 - :max-version "25.3" ;last version without testfn - :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))) - -(compat-defun string-trim-left (string &optional regexp) - "Trim STRING of leading string matching REGEXP. - -REGEXP defaults to \"[ \\t\\n\\r]+\"." - (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]+\"." - (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]+\"." - ;; `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 compat--gensym-counter - (setq compat--gensym-counter - (1+ compat--gensym-counter))))) - (make-symbol (format "%s%d" (or prefix "g") num)))) - -;;;; Defined in files.el - -(declare-function temporary-file-directory nil) -(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 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 compat--mounted-file-systems default-directory) - default-directory - temporary-file-directory)))) - -(provide 'compat-26.1) -;;; compat-26.1.el ends here diff --git a/compat-26.el b/compat-26.el new file mode 100644 index 0000000..83b89c5 --- /dev/null +++ b/compat-26.el @@ -0,0 +1,631 @@ +;;; 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: + +(eval-when-compile (require 'compat-macs)) +(declare-function compat-func-arity "compat" (func)) + +;;;; 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*))))))) + +(compat--inhibit-prefixed (provide 'compat-26)) +;;; compat-26.el ends here diff --git a/compat-27.1.el b/compat-27.el index 7afca8b..a5eb72e 100644 --- a/compat-27.1.el +++ b/compat-27.el @@ -1,8 +1,10 @@ -;;; compat-27.1.el --- Compatibility Layer for Emacs 27.1 -*- lexical-binding: t; -*- +;;; compat-27.el --- Compatibility Layer for Emacs 27.1 -*- lexical-binding: t; -*- -;; Copyright (C) 2021 Free Software Foundation, Inc. +;; 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 @@ -23,7 +25,17 @@ ;; Find here the functionality added in Emacs 27.1, needed by older ;; versions. ;; -;; Do NOT load this library manually. Instead require `compat'. +;; 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: @@ -52,7 +64,7 @@ is nil)." (when (listp object) (catch 'cycle (let ((hare object) (tortoise object) - (max 2) (q 2) ) + (max 2) (q 2)) (while (consp hare) (setq hare (cdr hare)) (when (and (or (/= 0 (setq q (1- q))) @@ -123,14 +135,18 @@ Letter-case is significant, but text properties are ignored." ;;;; Defined in json.c (declare-function json-parse-string nil (string &rest args)) -(declare-function json-encode-string "json" (object)) +(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. @@ -156,24 +172,72 @@ 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 (condition-case nil - (json-parse-string "[]") - (json-unavailable t) - (void-function t)) + :cond (not (condition-case nil + (equal (json-serialize '()) "{}") + (:success t) + (void-function nil) + (json-unavailable nil))) + :realname compat--json-serialize (require 'json) - (let ((json-false (or (plist-get args :false-object) :false)) - (json-null (or (plist-get args :null-object) :null))) - (json-encode-string object))) + (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 (condition-case nil - (json-parse-string "[]") - (json-unavailable t) - (void-function t)) + :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) @@ -200,10 +264,11 @@ 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 (condition-case nil - (json-parse-string "[]") - (json-unavailable t) - (void-function t)) + :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)) @@ -243,10 +308,11 @@ 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 (condition-case nil - (json-parse-string "[]") - (json-unavailable t) - (void-function t)) + :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)) @@ -258,9 +324,65 @@ represent a JSON false value. It defaults to `:false'." (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-defun setq-local (&rest pairs) +(compat-defmacro setq-local (&rest pairs) "Handle multiple assignments." :prefix t (unless (zerop (mod (length pairs) 2)) @@ -275,6 +397,7 @@ represent a JSON false value. It defaults to `:false'." body))) (cons 'progn (nreverse body)))) +;;* 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. @@ -283,6 +406,7 @@ 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. @@ -341,49 +465,76 @@ return nil." "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., @@ -428,6 +579,64 @@ in all cases, since that is the standard symbol for byte." (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 @@ -456,6 +665,7 @@ in all cases, since that is the standard symbol for byte." (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 @@ -490,5 +700,40 @@ The return value is a string (or nil in case we can’t find it)." (or (lm-header "package-version") (lm-header "version"))))))))) -(provide 'compat-27.1) -;;; compat-27.1.el ends here + +;;;; 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 diff --git a/compat-28.1.el b/compat-28.el index 028893b..0c399b4 100644 --- a/compat-28.1.el +++ b/compat-28.el @@ -1,8 +1,10 @@ -;;; compat-28.1.el --- Compatibility Layer for Emacs 28.1 -*- lexical-binding: t; -*- +;;; compat-28.el --- Compatibility Layer for Emacs 28.1 -*- lexical-binding: t; -*- -;; Copyright (C) 2021 Free Software Foundation, Inc. +;; 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 @@ -23,7 +25,17 @@ ;; Find here the functionality added in Emacs 28.1, needed by older ;; versions. ;; -;; Do NOT load this library manually. Instead require `compat'. +;; 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: @@ -31,6 +43,7 @@ ;;;; 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. @@ -46,7 +59,8 @@ Case is always significant and text properties are ignored." multibyte regular expressions. As the compatibility function for `string-search' is implemented via `string-match', these issues are inherited." - (when (and start-pos (< start-pos 0)) + (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)) @@ -105,6 +119,7 @@ inserted before contatenating." ;;;; 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 @@ -140,10 +155,16 @@ continuing as if the error did not occur." Optional arguments FROM and TO specify the substring of STRING to consider, and are interpreted as in `substring'." :prefix t - (string-width (substring string (or from 0) to))) + (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: @@ -157,78 +178,49 @@ If COUNT is non-nil and a natural number, the function will ;;;; 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-advise json-serialize (object &rest args) +(compat-defun json-serialize (object &rest args) "Handle top-level JSON values." - :cond (condition-case err - ;; Use `random' to prevent byte compiler from optimising - ;; the "pure" `json-serialize' call. - (ignore (json-serialize (if (random) 0 0))) - (wrong-type-argument (eq (cadr err) 'json-value-p)) - ;; `json-serialize' might be disabled at compile time, so we - ;; have to check if an error was raised that the function - ;; was not defined. - (void-function (eq (cadr err) 'json-serialize))) - :realname compat--json-serialize-handle-tlo + :prefix t :min-version "27" (if (or (listp object) (vectorp object)) - (apply oldfun object args) + (apply #'json-serialize object args) (substring (json-serialize (list object)) 1 -1))) -(compat-advise json-insert (object &rest args) +(compat-defun json-insert (object &rest args) "Handle top-level JSON values." - :cond (condition-case err - ;; Use `random' to prevent byte compiler from optimising - ;; the "pure" `json-serialize' call. - (ignore (json-serialize (if (random) 0 0))) - (wrong-type-argument (eq (cadr err) 'json-value-p)) - ;; `json-serialize' might be disabled at compile time, so we - ;; have to check if an error was raised that the function - ;; was not defined. - (void-function (eq (cadr err) 'json-serialize))) - :realname compat--json-insert-handle-tlo + :prefix t :min-version "27" (if (or (listp object) (vectorp object)) - (apply oldfun object args) - (insert (apply #'compat--json-serialize-handle-tlo oldfun object args)))) - -(compat-advise json-parse-string (string &rest args) + (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." - :cond (condition-case err - ;; Use `random' to prevent byte compiler from optimising - ;; the "pure" `json-serialize' call. - (ignore (json-parse-string (if (random) "0" "0"))) - (json-parse-error t) - ;; `json-parse-string' might be disabled at compile time, so - ;; we have to check if an error was raised that the function - ;; was not defined. - (void-function (eq (cadr err) 'json-parse-error))) - :realname compat--json-parse-string-handle-tlo + :prefix t :min-version "27" (if (string-match-p "\\`[[:space:]]*[[{]" string) - (apply oldfun string args) + (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 oldfun (concat "[" string "]") args) 0))) + (elt (apply #'json-parse-string (concat "[" string "]") args) 0))) -(compat-advise json-parse-buffer (&rest args) +(compat-defun json-parse-buffer (&rest args) "Handle top-level JSON values." - :cond (condition-case err - ;; Use `random' to prevent byte compiler from optimising - ;; the "pure" `json-serialize' call. - (ignore (json-parse-string (if (random) "0" "0"))) - (json-parse-error t) - ;; `json-parse-string' might be disabled at compile time, so - ;; we have to check if an error was raised that the function - ;; was not defined. - (void-function (eq (cadr err) 'json-parse-error))) - :realname compat--json-parse-buffer-handle-tlo + :prefix t :min-version "27" (if (looking-at-p "[[:space:]]*[[{]") - (apply oldfun args) + (apply #'json-parse-buffer args) (catch 'escape (atomic-change-group (with-syntax-table @@ -241,10 +233,86 @@ If COUNT is non-nil and a natural number, the function will (insert "[") (forward-sexp 1) (insert "]")))) - (throw 'escape (elt (apply oldfun args) 0)))))) + (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) + 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 "") @@ -261,6 +329,7 @@ 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. @@ -269,6 +338,35 @@ Point in BUFFER will be placed after the inserted text." (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 @@ -303,6 +401,7 @@ REPLACEMENT can use the following special elements: (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'." @@ -312,12 +411,12 @@ Also see `local-variable-p'." (void-variable nil (throw 'fail nil))) t)) -(declare-function gensym nil (&optional prefix)) +;;* 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 (gensym))) + (let ((quit (make-symbol "with-existing-directory-quit"))) `(catch ',quit (dolist (dir (list default-directory (expand-file-name "~/") @@ -330,6 +429,7 @@ If `default-directory' is already an existing directory, it's not changed." (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)) @@ -347,6 +447,10 @@ not a list, return a one-element list containing 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) @@ -502,8 +606,8 @@ as the new values of the bound variables in the recursive invocation." ;;;; Defined in files.el -(declare-function compat--string-trim-left "compat-26.1" (string &optional regexp)) -(declare-function compat--directory-name-p "compat-25.1" (name)) +(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 \".\". @@ -526,6 +630,7 @@ See also `file-name-sans-extension'." (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 @@ -536,6 +641,86 @@ 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) @@ -556,7 +741,7 @@ is included in the return value." (apply #'format prompt format-args)) (and default (or (not (stringp default)) - (not (null default))) + (> (length default) 0)) (format " (default %s)" (if (consp default) (car default) @@ -565,6 +750,7 @@ is included in the return value." ;;;; Defined in windows.el +;;* UNTESTED (compat-defun count-windows (&optional minibuf all-frames) "Handle optional argument ALL-FRAMES: @@ -582,6 +768,8 @@ just the selected frame." ;;;; 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 @@ -593,6 +781,7 @@ where the mouse button is clicked to find a thing nearby." ;;;; 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. @@ -607,6 +796,7 @@ Other uses risk returning non-nil value that point to the wrong 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), @@ -625,6 +815,7 @@ The previous values will be be restored upon exit." ;;;; 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 @@ -643,6 +834,8 @@ itself will be used instead as the function argument." ;;;; 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 @@ -662,5 +855,25 @@ directory or directories specified." (apply 'update-directory-autoloads (if (listp dir) dir (list dir))))) -(provide 'compat-28.1) -;;; compat-28.1.el ends here +;;;; 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 diff --git a/compat-29.1.el b/compat-29.el index 3ff48f4..57495c1 100644 --- a/compat-29.1.el +++ b/compat-29.el @@ -1,6 +1,6 @@ -;;; compat-29.1.el --- Compatibility Layer for Emacs 29.1 -*- lexical-binding: t; -*- +;;; compat-29.el --- Compatibility Layer for Emacs 29.1 -*- lexical-binding: t; -*- -;; Copyright (C) 2021 Free Software Foundation, Inc. +;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. ;; Author: Philip Kaludercic <philipk@posteo.net> ;; Keywords: lisp @@ -28,7 +28,6 @@ ;;; Code: (eval-when-compile (require 'compat-macs)) -(declare-function compat-maxargs-/= "compat" (func n)) ;;;; Defined in xdisp.c @@ -130,5 +129,5 @@ than this function." (end (substring string (- (length string) length))) (t (substring string 0 length))))) -(provide 'compat-29.1) -;;; compat-29.1.el ends here +(provide 'compat-29) +;;; compat-29.el ends here diff --git a/compat-font-lock.el b/compat-font-lock.el new file mode 100644 index 0000000..66a62e5 --- /dev/null +++ b/compat-font-lock.el @@ -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 diff --git a/compat-macs.el b/compat-macs.el index 5cf9e46..f661fd1 100644 --- a/compat-macs.el +++ b/compat-macs.el @@ -1,6 +1,6 @@ ;;; compat-macs.el --- Compatibility Macros -*- lexical-binding: t; -*- -;; Copyright (C) 2021 Free Software Foundation, Inc. +;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. ;; Author: Philip Kaludercic <philipk@posteo.net> ;; Keywords: lisp @@ -29,16 +29,29 @@ "Ignore all arguments." nil) -(defun compat-generate-common (name def-fn install-fn check-fn attr type) - "Common code for generating compatibility definitions for NAME. -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: +(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--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). @@ -52,6 +65,9 @@ attributes are handled, all others are ignored: - :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. @@ -67,55 +83,88 @@ attributes are handled, all others are ignored: - :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." +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) - (let ((file (or (and (boundp 'byte-compile-current-file) - byte-compile-current-file) - load-file-name - (buffer-file-name)))) - ;; Guess the version from the file the macro is - ;; being defined in. - (and (string-match - "compat-\\([[:digit:]]+\\.[[:digit:]]+\\)\\.\\(?:elc?\\)\\'" - file) - (match-string 1 file))))) + (version + ;; If you edit this, also edit `compat--generate-testable' in + ;; `compat-tests.el'. + (or (plist-get attr :version) + (let* ((file (car (last current-load-list))) + (file (if (stringp file) + ;; Some library, which requires compat-XY.el, + ;; is being compiled and compat-XY.el has not + ;; been compiled yet. + file + ;; compat-XY.el is being compiled. + (or (bound-and-true-p byte-compile-current-file) + ;; Fallback to the buffer being evaluated. + (buffer-file-name))))) + (if (and file + (string-match + "compat-\\([[:digit:]]+\\)\\.\\(?:elc?\\)\\'" file)) + (concat (match-string 1 file) ".1") + (error "BUG: No version number could be extracted"))))) (realname (or (plist-get attr :realname) (intern (format "compat--%S" name)))) - (body `(progn - ,(unless (plist-get attr :no-highlight) - `(font-lock-add-keywords - 'emacs-lisp-mode - ',`((,(concat "\\_<\\(" - (regexp-quote (symbol-name name)) - "\\)\\_>") - 1 font-lock-preprocessor-face prepend)))) - ,(funcall install-fn realname version)))) - `(progn - (put ',realname 'compat-type ',type) - (put ',realname 'compat-version ,version) - (put ',realname 'compat-doc ,(plist-get attr :note)) - (put ',name 'compat-def ',realname) - ,(funcall def-fn realname version) - (,@(cond - ((or (and min-version - (version< emacs-version min-version)) - (and max-version - (version< max-version emacs-version))) - '(compat--ignore)) - ((plist-get attr :prefix) - '(progn)) - ((and version (version<= version emacs-version)) - '(compat--ignore)) - (`(when (and ,(if cond cond t) - ,(funcall check-fn))))) - ,(if feature - ;; See https://nullprogram.com/blog/2018/02/22/: - `(eval-after-load ,feature `(funcall ',(lambda () ,body))) - body))))) + (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. @@ -130,7 +179,7 @@ attributes (see `compat-generate-common')." ;; 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<= "25" emacs-version) + (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 diff --git a/compat-tests.el b/compat-tests.el index ac2c5e4..5983e92 100644 --- a/compat-tests.el +++ b/compat-tests.el @@ -1,6 +1,6 @@ ;;; compat-tests.el --- Tests for compat.el -*- lexical-binding: t; -*- -;; Copyright (C) 2021 Free Software Foundation, Inc. +;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. ;; Author: Philip Kaludercic <philipk@posteo.net> ;; Package-Requires: ((emacs "28.1")) @@ -33,306 +33,359 @@ ;;; Code: (require 'ert) -(require 'compat) - -(defvar compat--current-fn nil) -(defvar compat--compat-fn nil) - -(defmacro compat--should (result &rest input) - "Generate code for test with INPUT evaluating to RESULT." - (let ((cfn (or compat--compat-fn - (intern (format "compat--%s" compat--current-fn)))) - (rfn compat--current-fn)) - (macroexp-progn - (list - `(should (equal (,cfn ,@input) ,result)) - (and (fboundp rfn) - `(should (equal (,rfn ,@input) ,result))))))) - -(defmacro compat--should* (result &rest input) - "Generate code for test with INPUT evaluating to RESULT." - (let ((cfn (or compat--compat-fn - (intern (format "compat--%s" compat--current-fn)))) - (rfn compat--current-fn)) - (macroexp-progn - (list - `(should (equal (funcall (apply-partially #',cfn #',rfn) ,@input) ,result)) - (and (and (fboundp rfn) - (or (not (eq (get cfn 'compat-type) 'advice)) - (not (get cfn 'compat-version)) - (version<= (get cfn 'compat-version) emacs-version))) - `(should (equal (,rfn ,@input) ,result))))))) - -(defmacro compat--mshould (result &rest input) - "Generate code for test with INPUT evaluating to RESULT." - (let ((cfn (or compat--compat-fn - (intern (format "compat--%s" compat--current-fn)))) - (rfn compat--current-fn)) - (macroexp-progn - (list - `(should (equal (macroexpand-all `(,',cfn ,,@input)) ,result)) - (and (fboundp rfn) - `(should (equal (macroexpand-all `(,',rfn ,,@input)) ,result))))))) - -(defmacro compat--error (error &rest input) - "Generate code for test FN with INPUT to signal ERROR." - (let ((cfn (or compat--compat-fn - (intern (format "compat--%s" compat--current-fn)))) - (rfn compat--current-fn)) - (macroexp-progn - (list - `(should-error (,cfn ,@input) :type ',error) - (and (fboundp rfn) - `(should-error (,rfn ,@input) :type ',error)))))) - -(defmacro compat--error* (error &rest input) - "Generate code for test FN with INPUT to signal ERROR." - (let ((cfn (or compat--compat-fn - (intern (format "compat--%s" compat--current-fn)))) - (rfn compat--current-fn)) - (macroexp-progn - (list - `(should-error (funcall (apply-partially #',cfn #',rfn) ,@input) :type ',error) - (and (and (fboundp rfn) - (or (not (eq (get cfn 'compat-type) 'advice)) - (not (get cfn 'compat-version)) - (version<= (get cfn 'compat-version) emacs-version))) - `(should-error (,rfn ,@input) :type ',error)))))) - -;; FIXME: extract the name of the test out of the ERT-test, instead -;; of having to re-declare the name of the test redundantly. -(defmacro compat-test (fn &rest body) - "Set `compat--current-fn' to FN in BODY. -If FN is a list, the car should be the actual function, and cadr -the compatibility function." - (declare (indent 1)) - (if (consp fn) - (setq compat--current-fn (if (symbolp (car fn)) - (car fn) - ;; Handle expressions - (eval (car fn) t)) - compat--compat-fn (if (symbolp (cadr fn)) - (cadr fn) - ;; Handle expressions - (eval (cadr fn) t))) - (setq compat--current-fn fn - compat--compat-fn nil)) - (macroexp-progn body)) + +(require 'compat-macs) + +(defun compat--generate-testable (name def-fn install-fn check-fn attr type) + "Generate a more verbose compatibility definition, fit for testing. +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 + ;; If you edit this, also edit `compat--generate-default' in + ;; compat-macs.el. + (or (plist-get attr :version) + (let* ((file (car (last current-load-list))) + (file (if (stringp file) + file + (or (bound-and-true-p byte-compile-current-file) + (buffer-file-name))))) + (if (and file + (string-match + "compat-\\([[:digit:]]+\\)\\.\\(?:elc?\\)\\'" file)) + (concat (match-string 1 file) ".1") + (error "BUG: No version number could be extracted"))))) + (realname (or (plist-get attr :realname) + (intern (format "compat--%S" name)))) + (body `(progn + (unless (or (null (get ',name 'compat-def)) + (eq (get ',name 'compat-def) ',realname)) + (error "Duplicate compatibility definition: %s (was %s, now %s)" + ',name (get ',name 'compat-def) ',realname)) + (put ',name 'compat-def ',realname) + ,(funcall install-fn realname version)))) + `(progn + (put ',realname 'compat-type ',type) + (put ',realname 'compat-version ,version) + (put ',realname 'compat-min-version ,min-version) + (put ',realname 'compat-max-version ,max-version) + (put ',realname 'compat-doc ,(plist-get attr :note)) + ,(funcall def-fn realname version) + (,@(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))))) + ,(if feature + ;; See https://nullprogram.com/blog/2018/02/22/: + `(eval-after-load ,feature `(funcall ',(lambda () ,body))) + body))))) + +(setq compat--generate-function #'compat--generate-testable) + +(defvar compat-testing) +(let ((compat-testing t)) + (load "compat.el")) + +(defvar compat-test-counter) + +(defun compat--ought (name compat) + "Implementation for the `ought' macro for NAME. +COMPAT is the name of the compatibility function the behaviour is +being compared against." + (lambda (result &rest args) + (let ((real-test (intern (format "%s-%04d-actual/ought" compat compat-test-counter))) + (comp-test (intern (format "%s-%04d-compat/ought" compat compat-test-counter)))) + (setq compat-test-counter (1+ compat-test-counter)) + (macroexp-progn + (list (and (fboundp name) + (or (not (get compat 'compat-version)) + (version<= emacs-version (get compat 'compat-version))) + `(ert-set-test + ',real-test + (make-ert-test + :name ',real-test + :tags '(,name) + :body (lambda () (should (equal ,result (,name ,@args))))))) + (and (fboundp compat) + `(ert-set-test + ',comp-test + (make-ert-test + :name ',comp-test + :tags '(,name) + :body (lambda () (should (equal ,result (,compat ,@args)))))))))))) + +(defun compat--expect (name compat) + "Implementation for the `expect' macro for NAME. +COMPAT is the name of the compatibility function the behaviour is +being compared against." + (lambda (error-spec &rest args) + (let ((real-test (intern (format "%s-%04d-actual/expect" compat compat-test-counter))) + (comp-test (intern (format "%s-%04d-compat/expect" compat compat-test-counter))) + (error-type (if (consp error-spec) (car error-spec) error-spec))) + (setq compat-test-counter (1+ compat-test-counter)) + (macroexp-progn + (list (and (fboundp name) + (or (not (get compat 'compat-version)) + (version<= emacs-version (get compat 'compat-version))) + `(ert-set-test + ',real-test + (make-ert-test + :name ',real-test + :tags '(,name) + :body (lambda () + (should + (let ((res (should-error (,name ,@args) :type ',error-type))) + (should + ,(if (consp error-spec) + `(equal res ',error-spec) + `(eq (car res) ',error-spec))))))))) + (and (fboundp compat) + `(ert-set-test + ',comp-test + (make-ert-test + :name ',comp-test + :tags '(,name) + :body (lambda () + (should + (let ((res (should-error (,name ,@args) :type ',error-type))) + (should + ,(if (consp error-spec) + `(equal res ',error-spec) + `(eq (car res) ',error-spec)))))))))))))) + +(defmacro compat-deftests (name &rest body) + "Test NAME in BODY." + (declare (debug (sexp &rest body)) + (indent 1)) + (let* ((compat-test-counter 0) + (real-name (if (consp name) (car name) name)) + (compat-name (if (consp name) + (cadr name) + (intern (format "compat--%s" real-name)))) + (env (list + (cons 'ought (compat--ought real-name compat-name)) + (cons 'expect (compat--expect real-name compat-name))))) + (and (or (not (get compat-name 'compat-min-version)) + (version< (get compat-name 'compat-min-version) emacs-version)) + (or (not (get compat-name 'compat-max-version)) + (version< emacs-version (get compat-name 'compat-max-version))) + (macroexpand-all + (macroexp-progn body) + (append env macroexpand-all-environment))))) -(ert-deftest compat-string-search () - "Check if `compat--string-search' was implemented correctly." - (compat-test string-search - ;; Find needle at the beginning of a haystack: - (compat--should 0 "a" "abb") - ;; Find needle at the begining of a haystack, with more potential - ;; needles that could be found: - (compat--should 0 "a" "abba") - ;; Find needle with more than one charachter at the beginning of - ;; a line: - (compat--should 0 "aa" "aabbb") - ;; Find a needle midstring: - (compat--should 1 "a" "bab") - ;; Find a needle at the end: - (compat--should 2 "a" "bba") - ;; Find a longer needle midstring: - (compat--should 1 "aa" "baab") - ;; Find a longer needle at the end: - (compat--should 2 "aa" "bbaa") - ;; Find a case-sensitive needle: - (compat--should 2 "a" "AAa") - ;; Find another case-sensitive needle: - (compat--should 2 "aa" "AAaa") - ;; Test regular expression quoting (1): - (compat--should 5 "." "abbbb.b") - ;; Test regular expression quoting (2): - (compat--should 5 ".*" "abbbb.*b") - ;; Attempt to find non-existent needle: - (compat--should nil "a" "bbb") - ;; Attempt to find non-existent needle that has the form of a - ;; regular expression: - (compat--should nil "." "bbb") - ;; Handle empty string as needle: - (compat--should 0 "" "abc") - ;; Handle empty string as haystack: - (compat--should nil "a" "") - ;; Handle empty string as needle and haystack: - (compat--should 0 "" "") - ;; Handle START argument: - (compat--should 3 "a" "abba" 1) - ;; Additional test copied from: - (compat--should 6 "zot" "foobarzot") - (compat--should 0 "foo" "foobarzot") - (compat--should nil "fooz" "foobarzot") - (compat--should nil "zot" "foobarzo") - (compat--should 0 "ab" "ab") - (compat--should nil "ab\0" "ab") - (compat--should 4 "ab" "abababab" 3) - (compat--should nil "ab" "ababac" 3) - (compat--should nil "aaa" "aa") - ;; The `make-string' calls with three arguments have been replaced - ;; here with the result of their evaluation, to avoid issues with - ;; older versions of Emacs that only support two arguments. - (compat--should 5 - (make-string 2 130) - ;; Per (concat "helló" (make-string 5 130 t) "bár") - "hellóbár") - (compat--should 5 - (make-string 2 127) - ;; Per (concat "helló" (make-string 5 127 t) "bár") - "hellóbár") - (compat--should 1 "\377" "a\377ø") - (compat--should 1 "\377" "a\377a") - (compat--should nil (make-string 1 255) "a\377ø") - (compat--should nil (make-string 1 255) "a\377a") - (compat--should 3 "fóo" "zotfóo") - (compat--should nil "\303" "aøb") - (compat--should nil "\270" "aøb") - (compat--should nil "ø" "\303\270") - (compat--should nil "ø" (make-string 32 ?a)) - (compat--should nil "ø" (string-to-multibyte (make-string 32 ?a))) - (compat--should 14 "o" (string-to-multibyte - (apply #'string (number-sequence ?a ?z)))) - (compat--should 2 "a\U00010f98z" "a\U00010f98a\U00010f98z") - (compat--error (args-out-of-range -1) "a" "abc" -1) - (compat--error (args-out-of-range 4) "a" "abc" 4) - (compat--error (args-out-of-range 100000000000) - "a" "abc" 100000000000) - (compat--should nil "a" "aaa" 3) - (compat--should nil "aa" "aa" 1) - (compat--should nil "\0" "") - (compat--should 0 "" "") - (compat--error (args-out-of-range 1) "" "" 1) - (compat--should 0 "" "abc") - (compat--should 2 "" "abc" 2) - (compat--should 3 "" "abc" 3) - (compat--error (args-out-of-range 4) "" "abc" 4) - (compat--error (args-out-of-range -1) "" "abc" -1) - (compat--should nil "ø" "foo\303\270") - (compat--should nil "\303\270" "ø") - (compat--should nil "\370" "ø") - (compat--should nil (string-to-multibyte "\370") "ø") - (compat--should nil "ø" "\370") - (compat--should nil "ø" (string-to-multibyte "\370")) - (compat--should nil "\303\270" "\370") - (compat--should nil (string-to-multibyte "\303\270") "\370") - (compat--should nil "\303\270" (string-to-multibyte "\370")) - (compat--should nil - (string-to-multibyte "\303\270") - (string-to-multibyte "\370")) - (compat--should nil "\370" "\303\270") - (compat--should nil (string-to-multibyte "\370") "\303\270") - (compat--should nil "\370" (string-to-multibyte "\303\270")) - (compat--should nil - (string-to-multibyte "\370") - (string-to-multibyte "\303\270")) - (compat--should 3 "\303\270" "foo\303\270") - (when (version<= "27" emacs-version) - ;; FIXME The commit a1f76adfb03c23bb4242928e8efe6193c301f0c1 in - ;; emacs.git fixes the behaviour of regular expressions matching - ;; raw bytes. The compatibility functions should updated to - ;; backport this behaviour. - (compat--should 2 (string-to-multibyte "\377") "ab\377c") - (compat--should 2 - (string-to-multibyte "o\303\270") - "foo\303\270")))) - -(ert-deftest compat-string-replace () - "Check if `compat--string-replace' was implemented correctly." - (compat-test string-replace - (compat--should "bba" "aa" "bb" "aaa") - (compat--should "AAA" "aa" "bb" "AAA") - ;; Additional test copied from subr-tests.el: - (compat--should "zot" "foo" "bar" "zot") - (compat--should "barzot" "foo" "bar" "foozot") - (compat--should "barbarzot" "foo" "bar" "barfoozot") - (compat--should "barfoobar" "zot" "bar" "barfoozot") - (compat--should "barfoobarot" "z" "bar" "barfoozot") - (compat--should "zat" "zot" "bar" "zat") - (compat--should "zat" "azot" "bar" "zat") - (compat--should "bar" "azot" "bar" "azot") - (compat--should "foozotbar" "azot" "bar" "foozotbar") - (compat--should "labarbarbarzot" "fo" "bar" "lafofofozot") - (compat--should "axb" "\377" "x" "a\377b") - (compat--should "axø" "\377" "x" "a\377ø") - (when (version<= "27" emacs-version) - ;; FIXME The commit a1f76adfb03c23bb4242928e8efe6193c301f0c1 - ;; in emacs.git fixes the behaviour of regular - ;; expressions matching raw bytes. The compatibility - ;; functions should updated to backport this - ;; behaviour. - (compat--should "axb" (string-to-multibyte "\377") "x" "a\377b") - (compat--should "axø" (string-to-multibyte "\377") "x" "a\377ø")) - (compat--should "ANAnas" "ana" "ANA" "ananas") - (compat--should "" "a" "" "") - (compat--should "" "a" "" "aaaaa") - (compat--should "" "ab" "" "ababab") - (compat--should "ccc" "ab" "" "abcabcabc") - (compat--should "aaaaaa" "a" "aa" "aaa") - (compat--should "defg" "abc" "defg" "abc") - (when (version<= "24.4" emacs-version) - ;; FIXME: Emacs 24.3 do not know of `wrong-length-argument' and - ;; therefore fail this test, even if the right symbol is being - ;; thrown. - (compat--error wrong-length-argument "" "x" "abc")))) - -(ert-deftest compat-length= () - "Check if `compat--string-length=' was implemented correctly." - (compat-test length= - (compat--should t '() 0) ;empty list - (compat--should t '(1) 1) ;single element - (compat--should t '(1 2 3) 3) ;multiple elements - (compat--should nil '(1 2 3) 2) ;less than - (compat--should nil '(1) 0) - (compat--should nil '(1 2 3) 4) ;more than - (compat--should nil '(1) 2) - (compat--should nil '() 1) - (compat--should t [] 0) ;empty vector - (compat--should t [1] 1) ;single element vector - (compat--should t [1 2 3] 3) ;multiple element vector - (compat--should nil [1 2 3] 2) ;less than - (compat--should nil [1 2 3] 4) ;more than - (compat--error wrong-type-argument 3 nil))) - -(ert-deftest compat-length< () - "Check if `compat--length<' was implemented correctly." - (compat-test length< - (compat--should nil '(1) 0) ;single element - (compat--should nil '(1 2 3) 2) ;multiple elements - (compat--should nil '(1 2 3) 3) ;equal length - (compat--should nil '(1) 1) - (compat--should t '(1 2 3) 4) ;more than - (compat--should t '(1) 2) - (compat--should t '() 1) - (compat--should nil [1] 0) ;single element vector - (compat--should nil [1 2 3] 2) ;multiple element vector - (compat--should nil [1 2 3] 3) ;equal length - (compat--should t [1 2 3] 4) ;more than - (compat--error wrong-type-argument 3 nil))) - -(ert-deftest compat-length> () - "Check if `compat--length>' was implemented correctly." - (compat-test length> - (compat--should t '(1) 0) ;single element - (compat--should t '(1 2 3) 2) ;multiple elements - (compat--should nil '(1 2 3) 3) ;equal length - (compat--should nil '(1) 1) - (compat--should nil '(1 2 3) 4) ;more than - (compat--should nil '(1) 2) - (compat--should nil '() 1) - (compat--should t [1] 0) ;single element vector - (compat--should t [1 2 3] 2) ;multiple element vector - (compat--should nil [1 2 3] 3) ;equal length - (compat--should nil [1 2 3] 4) ;more than - (compat--error wrong-type-argument 3 nil))) - -(ert-deftest compat-always () - "Check if `compat--always' was implemented correctly." - (compat-test always - (compat--should t) ;no arguments - (compat--should t 1) ;single argument - (compat--should t 1 2 3 4))) ;multiple arguments +(compat-deftests string-search + ;; Find needle at the beginning of a haystack: + (ought 0 "a" "abb") + ;; Find needle at the begining of a haystack, with more potential + ;; needles that could be found: + (ought 0 "a" "abba") + ;; Find needle with more than one charachter at the beginning of + ;; a line: + (ought 0 "aa" "aabbb") + ;; Find a needle midstring: + (ought 1 "a" "bab") + ;; Find a needle at the end: + (ought 2 "a" "bba") + ;; Find a longer needle midstring: + (ought 1 "aa" "baab") + ;; Find a longer needle at the end: + (ought 2 "aa" "bbaa") + ;; Find a case-sensitive needle: + (ought 2 "a" "AAa") + ;; Find another case-sensitive needle: + (ought 2 "aa" "AAaa") + ;; Test regular expression quoting (1): + (ought 5 "." "abbbb.b") + ;; Test regular expression quoting (2): + (ought 5 ".*" "abbbb.*b") + ;; Attempt to find non-existent needle: + (ought nil "a" "bbb") + ;; Attempt to find non-existent needle that has the form of a + ;; regular expression: + (ought nil "." "bbb") + ;; Handle empty string as needle: + (ought 0 "" "abc") + ;; Handle empty string as haystack: + (ought nil "a" "") + ;; Handle empty string as needle and haystack: + (ought 0 "" "") + ;; Handle START argument: + (ought 3 "a" "abba" 1) + ;; Additional test copied from: + (ought 6 "zot" "foobarzot") + (ought 0 "foo" "foobarzot") + (ought nil "fooz" "foobarzot") + (ought nil "zot" "foobarzo") + (ought 0 "ab" "ab") + (ought nil "ab\0" "ab") + (ought 4 "ab" "abababab" 3) + (ought nil "ab" "ababac" 3) + (ought nil "aaa" "aa") + ;; The `make-string' calls with three arguments have been replaced + ;; here with the result of their evaluation, to avoid issues with + ;; older versions of Emacs that only support two arguments. + (ought 5 + (make-string 2 130) + ;; Per (concat "helló" (make-string 5 130 t) "bár") + "hellóbár") + (ought 5 + (make-string 2 127) + ;; Per (concat "helló" (make-string 5 127 t) "bár") + "hellóbár") + (ought 1 "\377" "a\377ø") + (ought 1 "\377" "a\377a") + (ought nil (make-string 1 255) "a\377ø") + (ought nil (make-string 1 255) "a\377a") + (ought 3 "fóo" "zotfóo") + (ought nil "\303" "aøb") + (ought nil "\270" "aøb") + (ought nil "ø" "\303\270") + (ought nil "ø" (make-string 32 ?a)) + (ought nil "ø" (string-to-multibyte (make-string 32 ?a))) + (ought 14 "o" (string-to-multibyte + (apply #'string (number-sequence ?a ?z)))) + (ought 2 "a\U00010f98z" "a\U00010f98a\U00010f98z") + (expect (args-out-of-range -1) "a" "abc" -1) + (expect (args-out-of-range 4) "a" "abc" 4) + (expect (args-out-of-range 100000000000) + "a" "abc" 100000000000) + (ought nil "a" "aaa" 3) + (ought nil "aa" "aa" 1) + (ought nil "\0" "") + (ought 0 "" "") + (expect (args-out-of-range 1) "" "" 1) + (ought 0 "" "abc") + (ought 2 "" "abc" 2) + (ought 3 "" "abc" 3) + (expect (args-out-of-range 4) "" "abc" 4) + (expect (args-out-of-range -1) "" "abc" -1) + (ought nil "ø" "foo\303\270") + (ought nil "\303\270" "ø") + (ought nil "\370" "ø") + (ought nil (string-to-multibyte "\370") "ø") + (ought nil "ø" "\370") + (ought nil "ø" (string-to-multibyte "\370")) + (ought nil "\303\270" "\370") + (ought nil (string-to-multibyte "\303\270") "\370") + (ought nil "\303\270" (string-to-multibyte "\370")) + (ought nil + (string-to-multibyte "\303\270") + (string-to-multibyte "\370")) + (ought nil "\370" "\303\270") + (ought nil (string-to-multibyte "\370") "\303\270") + (ought nil "\370" (string-to-multibyte "\303\270")) + (ought nil + (string-to-multibyte "\370") + (string-to-multibyte "\303\270")) + (ought 3 "\303\270" "foo\303\270") + (when (version<= "27" emacs-version) + ;; FIXME The commit a1f76adfb03c23bb4242928e8efe6193c301f0c1 in + ;; emacs.git fixes the behaviour of regular expressions matching + ;; raw bytes. The compatibility functions should updated to + ;; backport this behaviour. + (ought 2 (string-to-multibyte "\377") "ab\377c") + (ought 2 + (string-to-multibyte "o\303\270") + "foo\303\270"))) + +(compat-deftests string-replace + (ought "bba" "aa" "bb" "aaa") + (ought "AAA" "aa" "bb" "AAA") + ;; Additional test copied from subr-tests.el: + (ought "zot" "foo" "bar" "zot") + (ought "barzot" "foo" "bar" "foozot") + (ought "barbarzot" "foo" "bar" "barfoozot") + (ought "barfoobar" "zot" "bar" "barfoozot") + (ought "barfoobarot" "z" "bar" "barfoozot") + (ought "zat" "zot" "bar" "zat") + (ought "zat" "azot" "bar" "zat") + (ought "bar" "azot" "bar" "azot") + (ought "foozotbar" "azot" "bar" "foozotbar") + (ought "labarbarbarzot" "fo" "bar" "lafofofozot") + (ought "axb" "\377" "x" "a\377b") + (ought "axø" "\377" "x" "a\377ø") + (when (version<= "27" emacs-version) + ;; FIXME The commit a1f76adfb03c23bb4242928e8efe6193c301f0c1 + ;; in emacs.git fixes the behaviour of regular + ;; expressions matching raw bytes. The compatibility + ;; functions should updated to backport this + ;; behaviour. + (ought "axb" (string-to-multibyte "\377") "x" "a\377b") + (ought "axø" (string-to-multibyte "\377") "x" "a\377ø")) + (ought "ANAnas" "ana" "ANA" "ananas") + (ought "" "a" "" "") + (ought "" "a" "" "aaaaa") + (ought "" "ab" "" "ababab") + (ought "ccc" "ab" "" "abcabcabc") + (ought "aaaaaa" "a" "aa" "aaa") + (ought "defg" "abc" "defg" "abc") + (when (version<= "24.4" emacs-version) + ;; FIXME: Emacs 24.3 do not know of `wrong-length-argument' and + ;; therefore fail this test, even if the right symbol is being + ;; thrown. + (expect wrong-length-argument "" "x" "abc"))) + +(compat-deftests length= + (ought t '() 0) ;empty list + (ought t '(1) 1) ;single element + (ought t '(1 2 3) 3) ;multiple elements + (ought nil '(1 2 3) 2) ;less than + (ought nil '(1) 0) + (ought nil '(1 2 3) 4) ;more than + (ought nil '(1) 2) + (ought nil '() 1) + (ought t [] 0) ;empty vector + (ought t [1] 1) ;single element vector + (ought t [1 2 3] 3) ;multiple element vector + (ought nil [1 2 3] 2) ;less than + (ought nil [1 2 3] 4) ;more than + (expect wrong-type-argument 3 nil)) + +(compat-deftests length< + (ought nil '(1) 0) ;single element + (ought nil '(1 2 3) 2) ;multiple elements + (ought nil '(1 2 3) 3) ;equal length + (ought nil '(1) 1) + (ought t '(1 2 3) 4) ;more than + (ought t '(1) 2) + (ought t '() 1) + (ought nil [1] 0) ;single element vector + (ought nil [1 2 3] 2) ;multiple element vector + (ought nil [1 2 3] 3) ;equal length + (ought t [1 2 3] 4) ;more than + (expect wrong-type-argument 3 nil)) + +(compat-deftests length> + (ought t '(1) 0) ;single element + (ought t '(1 2 3) 2) ;multiple elements + (ought nil '(1 2 3) 3) ;equal length + (ought nil '(1) 1) + (ought nil '(1 2 3) 4) ;more than + (ought nil '(1) 2) + (ought nil '() 1) + (ought t [1] 0) ;single element vector + (ought t [1 2 3] 2) ;multiple element vector + (ought nil [1 2 3] 3) ;equal length + (ought nil [1 2 3] 4) ;more than + (expect wrong-type-argument 3 nil)) + +(compat-deftests always + (ought t) ;no arguments + (ought t 1) ;single argument + (ought t 1 2 3 4)) ;multiple arguments (ert-deftest compat-insert-into-buffer () "Check if `insert-into-buffer' was implemented correctly." @@ -385,138 +438,120 @@ the compatibility function." (insert-into-buffer other 2 3)) (should (string= (buffer-string) "abce")))))) -(ert-deftest compat-file-name-with-extension () - "Check if `compat--file-name-with-extension' was implemented correctly." - (compat-test file-name-with-extension - (compat--should "file.ext" "file" "ext") - (compat--should "file.ext" "file" ".ext") - (compat--should "file.ext" "file." ".ext") - (compat--should "file..ext" "file.." ".ext") - (compat--should "file..ext" "file." "..ext") - (compat--should "file...ext" "file.." "..ext") - (compat--should "/abs/file.ext" "/abs/file" "ext") - (compat--should "/abs/file.ext" "/abs/file" ".ext") - (compat--should "/abs/file.ext" "/abs/file." ".ext") - (compat--should "/abs/file..ext" "/abs/file.." ".ext") - (compat--should "/abs/file..ext" "/abs/file." "..ext") - (compat--should "/abs/file...ext" "/abs/file.." "..ext") - (compat--error error "file" "") - (compat--error error "" "ext") - (compat--error error "file" "") - (compat--error error "rel/" "ext") - (compat--error error "/abs/" "ext"))) - -(ert-deftest compat-string-width () - "Check if `compat--string-width' was implemented correctly." - (compat-test compat-string-width - (compat--should 0 "") - (compat--should 3 "abc") ;no argument - (compat--should 5 "abcあ") - (compat--should (1+ tab-width) "a ") - (compat--should 2 "abc" 1) ;with from - (compat--should 4 "abcあ" 1) - (compat--should tab-width "a " 1) - (compat--should 2 "abc" 0 2) ;with to - (compat--should 3 "abcあ" 0 3) - (compat--should 1 "a " 0 1) - (compat--should 1 "abc" 1 2) ;with from and to - (compat--should 2 "abcあ" 3 4) - (compat--should 0 "a " 1 1))) - -(ert-deftest compat-ensure-list () - "Check if `compat--ensure-list' was implemented correctly." - (compat-test ensure-list - (compat--should nil nil) ;empty list - (compat--should '(1) '(1)) ;single element list - (compat--should '(1 2 3) '(1 2 3)) ;multiple element list - (compat--should '(1) 1))) ;atom - -(ert-deftest compat-proper-list-p-1 () - "Check if `compat--proper-list-p' was implemented correctly (>=26.1)." - (unless (version< emacs-version "26") - (compat-test (proper-list-p compat--proper-list-p-length-signal) - (compat--should 0 ()) ;empty list - (compat--should 1 '(1)) ;single element - (compat--should 3 '(1 2 3)) ;multiple elements - (compat--should nil '(1 . 2)) ;cons - (compat--should nil '(1 2 . 3)) ;dotted - (compat--should nil (let ((l (list 1 2 3))) ;circular - (setf (nthcdr 3 l) l) - l)) - (compat--should nil 1) ;non-lists - (compat--should nil "") - (compat--should nil "abc") - (compat--should nil []) - (compat--should nil [1 2 3])))) - -(ert-deftest compat-proper-list-p-2 () - "Check if `compat--proper-list-p' was implemented correctly (<25.3)." - (compat-test (proper-list-p compat--proper-list-p-tortoise-hare) - (compat--should 0 ()) ;empty list - (compat--should 1 '(1)) ;single element - (compat--should 3 '(1 2 3)) ;multiple elements - (compat--should nil '(1 . 2)) ;cons - (compat--should nil '(1 2 . 3)) ;dotted - (compat--should nil (let ((l (list 1 2 3))) ;circular - (setf (nthcdr 3 l) l) - l)) - (compat--should nil 1) ;non-lists - (compat--should nil "") - (compat--should nil "abc") - (compat--should nil []) - (compat--should nil [1 2 3]))) - - -(ert-deftest compat-flatten-tree () - "Check if `compat--flatten-tree' was implemented correctly." - (compat-test flatten-tree - ;; Example from docstring: - (compat--should '(1 2 3 4 5 6 7) '(1 (2 . 3) nil (4 5 (6)) 7)) - ;; Trivial example - (compat--should nil ()) - ;; Simple examples - (compat--should '(1) '(1)) - (compat--should '(1 2) '(1 2)) - (compat--should '(1 2 3) '(1 2 3)) - ;; Regular sublists - (compat--should '(1) '((1))) - (compat--should '(1 2) '((1) (2))) - (compat--should '(1 2 3) '((1) (2) (3))) - ;; Complex examples - (compat--should '(1) '(((((1)))))) - (compat--should '(1 2 3 4) '((1) nil 2 ((3 4)))) - (compat--should '(1 2 3 4) '(((1 nil)) 2 (((3 nil nil) 4)))))) - -(ert-deftest compat-xor () - "Check if `compat--xor' was implemented correctly." - (compat-test xor - (compat--should t t nil) - (compat--should t nil t) - (compat--should nil nil nil) - (compat--should nil t t))) - -(ert-deftest compat-string-distance () - "Check if `compat--string-distance' was implemented correctly." - (compat-test string-distance - (compat--should 3 "kitten" "sitting") ;from wikipedia - (if (version<= "28" emacs-version) ;trivial examples - (compat--should 0 "" "") - ;; Up until Emacs 28, `string-distance' had a bug - ;; when comparing two empty strings. This was fixed - ;; in the following commit: - ;; https://git.savannah.gnu.org/cgit/emacs.git/commit/?id=c44190c - ;; - ;; Therefore, we must make sure, that the test - ;; doesn't fail because of this bug: - (should (= (compat--string-distance "" "") 0))) - (compat--should 0 "a" "a") - (compat--should 1 "" "a") - (compat--should 1 "b" "a") - (compat--should 2 "aa" "bb") - (compat--should 2 "aa" "bba") - (compat--should 2 "aaa" "bba") - (compat--should 3 "a" "あ" t) ;byte example - (compat--should 1 "a" "あ"))) +(compat-deftests file-name-with-extension + (ought "file.ext" "file" "ext") + (ought "file.ext" "file" ".ext") + (ought "file.ext" "file." ".ext") + (ought "file..ext" "file.." ".ext") + (ought "file..ext" "file." "..ext") + (ought "file...ext" "file.." "..ext") + (ought "/abs/file.ext" "/abs/file" "ext") + (ought "/abs/file.ext" "/abs/file" ".ext") + (ought "/abs/file.ext" "/abs/file." ".ext") + (ought "/abs/file..ext" "/abs/file.." ".ext") + (ought "/abs/file..ext" "/abs/file." "..ext") + (ought "/abs/file...ext" "/abs/file.." "..ext") + (expect error "file" "") + (expect error "" "ext") + (expect error "file" "") + (expect error "rel/" "ext") + (expect error "/abs/" "ext")) + +(compat-deftests compat-string-width + (ought 0 "") + (ought 3 "abc") ;no argument + (ought 5 "abcあ") + (ought (1+ tab-width) "a ") + (ought 2 "abc" 1) ;with from + (ought 4 "abcあ" 1) + (ought tab-width "a " 1) + (ought 2 "abc" 0 2) ;with to + (ought 3 "abcあ" 0 3) + (ought 1 "a " 0 1) + (ought 1 "abc" 1 2) ;with from and to + (ought 2 "abcあ" 3 4) + (ought 0 "a " 1 1)) + +(compat-deftests ensure-list + (ought nil nil) ;empty list + (ought '(1) '(1)) ;single element list + (ought '(1 2 3) '(1 2 3)) ;multiple element list + (ought '(1) 1)) ;atom + +(compat-deftests (proper-list-p compat--proper-list-p-length-signal) + (ought 0 ()) ;empty list + (ought 1 '(1)) ;single element + (ought 3 '(1 2 3)) ;multiple elements + (ought nil '(1 . 2)) ;cons + (ought nil '(1 2 . 3)) ;dotted + (ought nil (let ((l (list 1 2 3))) ;circular + (setf (nthcdr 3 l) l) + l)) + (ought nil 1) ;non-lists + (ought nil "") + (ought nil "abc") + (ought nil []) + (ought nil [1 2 3])) + +(compat-deftests (proper-list-p compat--proper-list-p-tortoise-hare) + (ought 0 ()) ;empty list + (ought 1 '(1)) ;single element + (ought 3 '(1 2 3)) ;multiple elements + (ought nil '(1 . 2)) ;cons + (ought nil '(1 2 . 3)) ;dotted + (ought nil (let ((l (list 1 2 3))) ;circular + (setf (nthcdr 3 l) l) + l)) + (ought nil 1) ;non-lists + (ought nil "") + (ought nil "abc") + (ought nil []) + (ought nil [1 2 3])) + +(compat-deftests flatten-tree + ;; Example from docstring: + (ought '(1 2 3 4 5 6 7) '(1 (2 . 3) nil (4 5 (6)) 7)) + ;; Trivial example + (ought nil ()) + ;; Simple examples + (ought '(1) '(1)) + (ought '(1 2) '(1 2)) + (ought '(1 2 3) '(1 2 3)) + ;; Regular sublists + (ought '(1) '((1))) + (ought '(1 2) '((1) (2))) + (ought '(1 2 3) '((1) (2) (3))) + ;; Complex examples + (ought '(1) '(((((1)))))) + (ought '(1 2 3 4) '((1) nil 2 ((3 4)))) + (ought '(1 2 3 4) '(((1 nil)) 2 (((3 nil nil) 4))))) + +(compat-deftests xor + (ought t t nil) + (ought t nil t) + (ought nil nil nil) + (ought nil t t)) + +(compat-deftests string-distance + (ought 3 "kitten" "sitting") ;from wikipedia + (if (version<= "28" emacs-version) ;trivial examples + (ought 0 "" "") + ;; Up until Emacs 28, `string-distance' had a bug + ;; when comparing two empty strings. This was fixed + ;; in the following commit: + ;; https://git.savannah.gnu.org/cgit/emacs.git/commit/?id=c44190c + ;; + ;; Therefore, we must make sure, that the test + ;; doesn't fail because of this bug: + (should (= (compat--string-distance "" "") 0))) + (ought 0 "a" "a") + (ought 1 "" "a") + (ought 1 "b" "a") + (ought 2 "aa" "bb") + (ought 2 "aa" "bba") + (ought 2 "aaa" "bba") + (ought 3 "a" "あ" t) ;byte example + (ought 1 "a" "あ")) (ert-deftest compat-regexp-unmatchable () "Check if `compat--string-distance' was implemented correctly." @@ -528,205 +563,208 @@ the compatibility function." (when (boundp 'regexp-unmatchable) (should-not (string-match-p regexp-unmatchable str))))) +(compat-deftests compat-regexp-opt + ;; Ensure `compat--regexp-opt' doesn't change the existing + ;; behaviour: + (ought (regexp-opt '("a" "b" "c")) '("a" "b" "c")) + (ought (regexp-opt '("abc" "def" "ghe")) '("abc" "def" "ghe")) + (ought (regexp-opt '("a" "b" "c") 'words) '("a" "b" "c") 'words) + ;; Test empty list: + (ought "\\(?:\\`a\\`\\)" '()) + (ought "\\<\\(\\`a\\`\\)\\>" '() 'words)) + (ert-deftest compat-regexp-opt () "Check if `compat--regexp-opt' advice was defined correctly." - (compat-test compat-regexp-opt - ;; Ensure `compat--regexp-opt' doesn't change the existing - ;; behaviour: - (compat--should (regexp-opt '("a" "b" "c")) '("a" "b" "c")) - (compat--should (regexp-opt '("abc" "def" "ghe")) '("abc" "def" "ghe")) - (compat--should (regexp-opt '("a" "b" "c") 'words) '("a" "b" "c") 'words) - ;; Test empty list: - (compat--should "\\(?:\\`a\\`\\)" '()) - (compat--should "\\<\\(\\`a\\`\\)\\>" '() 'words)) - (let ((unmatchable (compat--compat-regexp-opt '()))) + (let ((unmatchable "\\(?:\\`a\\`\\)")) (dolist (str '("" ;empty string "a" ;simple string "aaa" ;longer string )) (should-not (string-match-p unmatchable str))))) -(ert-deftest compat-assoc () - "Check if `compat--assoc' advice was advised correctly." - (compat-test compat-assoc - ;; Fallback behaviour: - (compat--should nil 1 nil) ;empty list - (compat--should '(1) 1 '((1))) ;single element list - (compat--should nil 1 '(1)) - (compat--should '(2) 2 '((1) (2) (3))) ;multiple element list - (compat--should nil 2 '(1 2 3)) - (compat--should '(2) 2 '(1 (2) 3)) - (compat--should nil 2 '((1) 2 (3))) - (compat--should '(1) 1 '((3) (2) (1))) - (compat--should '("a") "a" '(("a") ("b") ("c"))) ;non-primitive elements - (compat--should '("a" 0) "a" '(("c" . "a") "b" ("a" 0))) - ;; With testfn (advised behaviour): - (compat--should '(1) 3 '((10) (4) (1) (9)) #'<) - (compat--should '("a") "b" '(("c") ("a") ("b")) #'string-lessp) - (compat--should '("b") "a" '(("a") ("a") ("b")) - (lambda (s1 s2) (not (string= s1 s2)))) - (compat--should - '("\\.el\\'" . emacs-lisp-mode) - "file.el" - '(("\\.c\\'" . c-mode) - ("\\.p\\'" . pascal-mode) - ("\\.el\\'" . emacs-lisp-mode) - ("\\.awk\\'" . awk-mode)) - #'string-match-p))) +(compat-deftests compat-assoc + ;; Fallback behaviour: + (ought nil 1 nil) ;empty list + (ought '(1) 1 '((1))) ;single element list + (ought nil 1 '(1)) + (ought '(2) 2 '((1) (2) (3))) ;multiple element list + (ought nil 2 '(1 2 3)) + (ought '(2) 2 '(1 (2) 3)) + (ought nil 2 '((1) 2 (3))) + (ought '(1) 1 '((3) (2) (1))) + (ought '("a") "a" '(("a") ("b") ("c"))) ;non-primitive elements + (ought '("a" 0) "a" '(("c" . "a") "b" ("a" 0))) + ;; With testfn (advised behaviour): + (ought '(1) 3 '((10) (4) (1) (9)) #'<) + (ought '("a") "b" '(("c") ("a") ("b")) #'string-lessp) + (ought '("b") "a" '(("a") ("a") ("b")) + (lambda (s1 s2) (not (string= s1 s2)))) + (ought + '("\\.el\\'" . emacs-lisp-mode) + "file.el" + '(("\\.c\\'" . c-mode) + ("\\.p\\'" . pascal-mode) + ("\\.el\\'" . emacs-lisp-mode) + ("\\.awk\\'" . awk-mode)) + #'string-match-p)) ;; (when (fboundp 'alist-get) ;; (ert-deftest compat-alist-get-1 () ;; "Check if `compat--alist-get' was advised correctly." -;; (compat-test compat-alist-get +;; (compat-deftests compat-alist-get ;; ;; Fallback behaviour: -;; (compat--should nil 1 nil) ;empty list -;; (compat--should 'a 1 '((1 . a))) ;single element list -;; (compat--should nil 1 '(1)) -;; (compat--should 'b 2 '((1 . a) (2 . b) (3 . c))) ;multiple element list -;; (compat--should nil 2 '(1 2 3)) -;; (compat--should 'b 2 '(1 (2 . b) 3)) -;; (compat--should nil 2 '((1 . a) 2 (3 . c))) -;; (compat--should 'a 1 '((3 . c) (2 . b) (1 . a))) -;; (compat--should nil "a" '(("a" . 1) ("b" . 2) ("c" . 3))) ;non-primitive elements +;; (ought nil 1 nil) ;empty list +;; (ought 'a 1 '((1 . a))) ;single element list +;; (ought nil 1 '(1)) +;; (ought 'b 2 '((1 . a) (2 . b) (3 . c))) ;multiple element list +;; (ought nil 2 '(1 2 3)) +;; (ought 'b 2 '(1 (2 . b) 3)) +;; (ought nil 2 '((1 . a) 2 (3 . c))) +;; (ought 'a 1 '((3 . c) (2 . b) (1 . a))) +;; (ought nil "a" '(("a" . 1) ("b" . 2) ("c" . 3))) ;non-primitive elements ;; ;; With testfn (advised behaviour): -;; (compat--should 1 "a" '(("a" . 1) ("b" . 2) ("c" . 3)) nil nil #'equal) -;; (compat--should 1 3 '((10 . 10) (4 . 4) (1 . 1) (9 . 9)) nil nil #'<) -;; (compat--should '(a) "b" '(("c" c) ("a" a) ("b" b)) nil nil #'string-lessp) -;; (compat--should 'c "a" '(("a" . a) ("a" . b) ("b" . c)) nil nil +;; (ought 1 "a" '(("a" . 1) ("b" . 2) ("c" . 3)) nil nil #'equal) +;; (ought 1 3 '((10 . 10) (4 . 4) (1 . 1) (9 . 9)) nil nil #'<) +;; (ought '(a) "b" '(("c" c) ("a" a) ("b" b)) nil nil #'string-lessp) +;; (ought 'c "a" '(("a" . a) ("a" . b) ("b" . c)) nil nil ;; (lambda (s1 s2) (not (string= s1 s2)))) -;; (compat--should 'emacs-lisp-mode +;; (ought 'emacs-lisp-mode ;; "file.el" ;; '(("\\.c\\'" . c-mode) ;; ("\\.p\\'" . pascal-mode) ;; ("\\.el\\'" . emacs-lisp-mode) ;; ("\\.awk\\'" . awk-mode)) ;; nil nil #'string-match-p) -;; (compat--should 'd 0 '((1 . a) (2 . b) (3 . c)) 'd) ;default value -;; (compat--should 'd 2 '((1 . a) (2 . b) (3 . c)) 'd nil #'ignore)))) - -(ert-deftest compat-alist-get-2 () - "Check if `compat--alist-get' was implemented correctly." - (compat-test (alist-get compat--alist-get-full-elisp) - ;; Fallback behaviour: - (compat--should nil 1 nil) ;empty list - (compat--should 'a 1 '((1 . a))) ;single element list - (compat--should nil 1 '(1)) - (compat--should 'b 2 '((1 . a) (2 . b) (3 . c))) ;multiple element list - (compat--should nil 2 '(1 2 3)) - (compat--should 'b 2 '(1 (2 . b) 3)) - (compat--should nil 2 '((1 . a) 2 (3 . c))) - (compat--should 'a 1 '((3 . c) (2 . b) (1 . a))) - (compat--should nil "a" '(("a" . 1) ("b" . 2) ("c" . 3)))) ;non-primitive elements - (compat-test ((and (version<= "26.1" emacs-version) #'alist-get) - compat--alist-get-full-elisp) - ;; With testfn (advised behaviour): - (compat--should 1 "a" '(("a" . 1) ("b" . 2) ("c" . 3)) nil nil #'equal) - (compat--should 1 3 '((10 . 10) (4 . 4) (1 . 1) (9 . 9)) nil nil #'<) - (compat--should '(a) "b" '(("c" c) ("a" a) ("b" b)) nil nil #'string-lessp) - (compat--should 'c "a" '(("a" . a) ("a" . b) ("b" . c)) nil nil - (lambda (s1 s2) (not (string= s1 s2)))) - (compat--should 'emacs-lisp-mode - "file.el" - '(("\\.c\\'" . c-mode) - ("\\.p\\'" . pascal-mode) - ("\\.el\\'" . emacs-lisp-mode) - ("\\.awk\\'" . awk-mode)) - nil nil #'string-match-p) - (compat--should 'd 0 '((1 . a) (2 . b) (3 . c)) 'd) ;default value - (compat--should 'd 2 '((1 . a) (2 . b) (3 . c)) 'd nil #'ignore))) - -(ert-deftest compat-string-trim-left () - "Check if `compat--string-trim-left' was implemented correctly." - (compat-test string-trim-left' - (compat--should "" "") ;empty string - (compat--should "a" "a") ;"full" string - (compat--should "aaa" "aaa") - (compat--should "へっろ" "へっろ") - (compat--should "hello world" "hello world") - (compat--should "a " "a ") ;right trailing - (compat--should "aaa " "aaa ") - (compat--should "a " "a ") - (compat--should "a\t\t" "a\t\t") - (compat--should "a\n \t" "a\n \t") - (compat--should "a" " a") ;left trailing - (compat--should "aaa" " aaa") - (compat--should "a" "a") - (compat--should "a" "\t\ta") - (compat--should "a" "\n \ta") - (compat--should "a " " a ") ;both trailing - (compat--should "aaa " " aaa ") - (compat--should "a\t\n" "\t\ta\t\n") - (compat--should "a \n" "\n \ta \n"))) - -(ert-deftest compat-string-trim-right () - "Check if `compat--string-trim-right' was implemented correctly." - (compat-test string-trim-right - (compat--should "" "") ;empty string - (compat--should "a" "a") ;"full" string - (compat--should "aaa" "aaa") - (compat--should "へっろ" "へっろ") - (compat--should "hello world" "hello world") - (compat--should "a" "a") ;right trailing - (compat--should "aaa" "aaa") - (compat--should "a" "a ") - (compat--should "a" "a\t\t") - (compat--should "a" "a\n \t") - (compat--should " a" " a") ;left trailing - (compat--should " aaa" " aaa") - (compat--should "a" "a") - (compat--should "\t\ta" "\t\ta") - (compat--should "\n \ta" "\n \ta") - (compat--should " a" " a ") ;both trailing - (compat--should " aaa" " aaa") - (compat--should "\t\ta" "\t\ta\t\n") - (compat--should "\n \ta" "\n \ta \n"))) - -(ert-deftest compat-string-trim () - "Check if `compat--string-trim' was implemented correctly." - (compat-test string-trim - (compat--should "" "") ;empty string - (compat--should "a" "a") ;"full" string - (compat--should "aaa" "aaa") - (compat--should "へっろ" "へっろ") - (compat--should "hello world" "hello world") - (compat--should "a" "a ") ;right trailing - (compat--should "aaa" "aaa ") - (compat--should "a" "a ") - (compat--should "a" "a\t\t") - (compat--should "a" "a\n \t") - (compat--should "a" " a") ;left trailing - (compat--should "aaa" " aaa") - (compat--should "a" "a") - (compat--should "a" "\t\ta") - (compat--should "a" "\n \ta") - (compat--should "a" " a ") ;both trailing - (compat--should "aaa" " aaa ") - (compat--should "t\ta" "t\ta\t\n") - (compat--should "a" "\n \ta \n"))) - -(ert-deftest compat-mapcan () - "Check if `compat--mapcan' was implemented correctly." - (compat-test mapcan - (compat--should nil #'identity nil) - (compat--should (list 1) - #'identity - (list (list 1))) - (compat--should (list 1 2 3 4) - #'identity - (list (list 1) (list 2 3) (list 4))) - (compat--should (list (list 1) (list 2 3) (list 4)) - #'list - (list (list 1) (list 2 3) (list 4))) - (compat--should (list 1 2 3 4) - #'identity - (list (list 1) (list) (list 2 3) (list 4))) - (compat--should (list (list 1) (list) (list 2 3) (list 4)) - #'list - (list (list 1) (list) (list 2 3) (list 4))) - (compat--should (list) - #'identity - (list (list) (list) (list) (list))))) +;; (ought 'd 0 '((1 . a) (2 . b) (3 . c)) 'd) ;default value +;; (ought 'd 2 '((1 . a) (2 . b) (3 . c)) 'd nil #'ignore)))) + +(compat-deftests (alist-get compat--alist-get-full-elisp) + ;; Fallback behaviour: + (ought nil 1 nil) ;empty list + (ought 'a 1 '((1 . a))) ;single element list + (ought nil 1 '(1)) + (ought 'b 2 '((1 . a) (2 . b) (3 . c))) ;multiple element list + (ought nil 2 '(1 2 3)) + (ought 'b 2 '(1 (2 . b) 3)) + (ought nil 2 '((1 . a) 2 (3 . c))) + (ought 'a 1 '((3 . c) (2 . b) (1 . a))) + (ought nil "a" '(("a" . 1) ("b" . 2) ("c" . 3))) ;non-primitive elements + ;; With testfn (advised behaviour): + (ought 1 "a" '(("a" . 1) ("b" . 2) ("c" . 3)) nil nil #'equal) + (ought 1 3 '((10 . 10) (4 . 4) (1 . 1) (9 . 9)) nil nil #'<) + (ought '(a) "b" '(("c" c) ("a" a) ("b" b)) nil nil #'string-lessp) + (ought 'c "a" '(("a" . a) ("a" . b) ("b" . c)) nil nil + (lambda (s1 s2) (not (string= s1 s2)))) + (ought 'emacs-lisp-mode + "file.el" + '(("\\.c\\'" . c-mode) + ("\\.p\\'" . pascal-mode) + ("\\.el\\'" . emacs-lisp-mode) + ("\\.awk\\'" . awk-mode)) + nil nil #'string-match-p) + (ought 'd 0 '((1 . a) (2 . b) (3 . c)) 'd) ;default value + (ought 'd 2 '((1 . a) (2 . b) (3 . c)) 'd nil #'ignore)) + +(ert-deftest compat-alist-get-gv () + "Test if the `compat-alist-get' can be used as a generalised variable." + (let ((alist-1 (list (cons 1 "one") + (cons 2 "two") + (cons 3 "three"))) + (alist-2 (list (cons "one" 1) + (cons "two" 2) + (cons "three" 3)))) + (setf (compat-alist-get 1 alist-1) "eins") + (should (equal (compat-alist-get 1 alist-1) "eins")) + (setf (compat-alist-get 2 alist-1 nil 'remove) nil) + (should (equal alist-1 '((1 . "eins") (3 . "three")))) + (setf (compat-alist-get "one" alist-2 nil nil #'string=) "eins") + (should (equal (compat-alist-get "one" alist-2 nil nil #'string=) + "eins")))) + +(compat-deftests string-trim-left + (ought "" "") ;empty string + (ought "a" "a") ;"full" string + (ought "aaa" "aaa") + (ought "へっろ" "へっろ") + (ought "hello world" "hello world") + (ought "a " "a ") ;right trailing + (ought "aaa " "aaa ") + (ought "a " "a ") + (ought "a\t\t" "a\t\t") + (ought "a\n \t" "a\n \t") + (ought "a" " a") ;left trailing + (ought "aaa" " aaa") + (ought "a" "a") + (ought "a" "\t\ta") + (ought "a" "\n \ta") + (ought "a " " a ") ;both trailing + (ought "aaa " " aaa ") + (ought "a\t\n" "\t\ta\t\n") + (ought "a \n" "\n \ta \n")) + +(compat-deftests string-trim-right + (ought "" "") ;empty string + (ought "a" "a") ;"full" string + (ought "aaa" "aaa") + (ought "へっろ" "へっろ") + (ought "hello world" "hello world") + (ought "a" "a") ;right trailing + (ought "aaa" "aaa") + (ought "a" "a ") + (ought "a" "a\t\t") + (ought "a" "a\n \t") + (ought " a" " a") ;left trailing + (ought " aaa" " aaa") + (ought "a" "a") + (ought "\t\ta" "\t\ta") + (ought "\n \ta" "\n \ta") + (ought " a" " a ") ;both trailing + (ought " aaa" " aaa") + (ought "\t\ta" "\t\ta\t\n") + (ought "\n \ta" "\n \ta \n")) + +(compat-deftests string-trim + (ought "" "") ;empty string + (ought "a" "a") ;"full" string + (ought "aaa" "aaa") + (ought "へっろ" "へっろ") + (ought "hello world" "hello world") + (ought "a" "a ") ;right trailing + (ought "aaa" "aaa ") + (ought "a" "a ") + (ought "a" "a\t\t") + (ought "a" "a\n \t") + (ought "a" " a") ;left trailing + (ought "aaa" " aaa") + (ought "a" "a") + (ought "a" "\t\ta") + (ought "a" "\n \ta") + (ought "a" " a ") ;both trailing + (ought "aaa" " aaa ") + (ought "t\ta" "t\ta\t\n") + (ought "a" "\n \ta \n")) + +(compat-deftests mapcan + (ought nil #'identity nil) + (ought (list 1) + #'identity + (list (list 1))) + (ought (list 1 2 3 4) + #'identity + (list (list 1) (list 2 3) (list 4))) + (ought (list (list 1) (list 2 3) (list 4)) + #'list + (list (list 1) (list 2 3) (list 4))) + (ought (list 1 2 3 4) + #'identity + (list (list 1) (list) (list 2 3) (list 4))) + (ought (list (list 1) (list) (list 2 3) (list 4)) + #'list + (list (list 1) (list) (list 2 3) (list 4))) + (ought (list) + #'identity + (list (list) (list) (list) (list)))) ;; Note: as the cXXX+r implementations are relatively trivial, their ;; tests are not as extensive. @@ -740,443 +778,359 @@ the compatibility function." (((i . j) . (k . l)) . ((m . j) . (o . p)))) "Testcase for cXXXXr functions.") -(ert-deftest compat-caaar () - "Check if `compat--caaar' was implemented correctly." - (compat-test caaar - (compat--should nil ()) - (compat--should 'a compat-cXXXr-test))) - -(ert-deftest compat-caadr () - "Check if `compat--caadr' was implemented correctly." - (compat-test caadr - (compat--should nil ()) - (compat--should 'e compat-cXXXr-test))) - -(ert-deftest compat-cadar () - "Check if `compat--cadar' was implemented correctly." - (compat-test cadar - (compat--should nil ()) - (compat--should 'c compat-cXXXr-test))) - -(ert-deftest compat-caddr () - "Check if `compat--caddr' was implemented correctly." - (compat-test caddr - (compat--should nil ()) - (compat--should 'g compat-cXXXr-test))) - -(ert-deftest compat-cdaar () - "Check if `compat--cdaar' was implemented correctly." - (compat-test cdaar - (compat--should nil ()) - (compat--should 'b compat-cXXXr-test))) - -(ert-deftest compat-cdadr () - "Check if `compat--cdadr' was implemented correctly." - (compat-test cdadr - (compat--should nil ()) - (compat--should 'f compat-cXXXr-test))) - -(ert-deftest compat-cddar () - "Check if `compat--cddar' was implemented correctly." - (compat-test cddar - (compat--should nil ()) - (compat--should 'd compat-cXXXr-test))) - -(ert-deftest compat-cdddr () - "Check if `compat--cdddr' was implemented correctly." - (compat-test cdddr - (compat--should nil ()) - (compat--should 'h compat-cXXXr-test) - #'cdddr)) - -(ert-deftest compat-caaaar () - "Check if `compat--caaaar' was implemented correctly." - (compat-test caaaar - (compat--should nil ()) - (compat--should 'a compat-cXXXXr-test))) - -(ert-deftest compat-caaadr () - "Check if `compat--caaadr' was implemented correctly." - (compat-test caaadr - (compat--should nil ()) - (compat--should 'i compat-cXXXXr-test))) - -(ert-deftest compat-caadar () - "Check if `compat--caadar' was implemented correctly." - (compat-test caadar - (compat--should nil ()) - (compat--should 'e compat-cXXXXr-test))) - -(ert-deftest compat-caaddr () - "Check if `compat--caaddr' was implemented correctly." - (compat-test caaddr - (compat--should nil ()) - (compat--should 'm compat-cXXXXr-test))) - -(ert-deftest compat-cadaar () - "Check if `compat--cadaar' was implemented correctly." - (compat-test cadaar - (compat--should nil ()) - (compat--should 'c compat-cXXXXr-test))) - -(ert-deftest compat-cadadr () - "Check if `compat--cadadr' was implemented correctly." - (compat-test cadadr - (compat--should nil ()) - (compat--should 'k compat-cXXXXr-test))) - -(ert-deftest compat-caddar () - "Check if `compat--caddar' was implemented correctly." - (compat-test caddar - (compat--should nil ()) - (compat--should 'g compat-cXXXXr-test))) - -(ert-deftest compat-cadddr () - "Check if `compat--cadddr' was implemented correctly." - (compat-test cadddr - (compat--should nil ()) - (compat--should 'o compat-cXXXXr-test))) - -(ert-deftest compat-cdaaar () - "Check if `compat--cdaaar' was implemented correctly." - (compat-test cdaaar - (compat--should nil ()) - (compat--should 'b compat-cXXXXr-test))) - -(ert-deftest compat-cdaadr () - "Check if `compat--cdaadr' was implemented correctly." - (compat-test cdaadr - (compat--should nil ()) - (compat--should 'j compat-cXXXXr-test))) - -(ert-deftest compat-cdadar () - "Check if `compat--cdadar' was implemented correctly." - (compat-test cdadar - (compat--should nil ()) - (compat--should 'f compat-cXXXXr-test))) - -(ert-deftest compat-cdaddr () - "Check if `compat--cdaddr' was implemented correctly." - (compat-test cdaddr - (compat--should nil ()) - (compat--should 'j compat-cXXXXr-test))) - -(ert-deftest compat-cddaar () - "Check if `compat--cddaar' was implemented correctly." - (compat-test cddaar - (compat--should nil ()) - (compat--should 'd compat-cXXXXr-test))) - -(ert-deftest compat-cddadr () - "Check if `compat--cddadr' was implemented correctly." - (compat-test cddadr - (compat--should nil ()) - (compat--should 'l compat-cXXXXr-test))) - -(ert-deftest compat-cdddar () - "Check if `compat--cdddar' was implemented correctly." - (compat-test cdddar - (compat--should nil ()) - (compat--should 'h compat-cXXXXr-test))) - -(ert-deftest compat-string-greaterp () - "Check if `compat--string-greaterp' was implemented correctly." - (compat-test string-greaterp - (compat--should t "b" "a") - (compat--should nil "a" "b") - (compat--should t "aaab" "aaaa") - (compat--should nil "aaaa" "aaab"))) - -(ert-deftest compat-sort () - "Check if `compat--sort' was advised correctly." - (compat-test compat-sort - (compat--should (list 1 2 3) (list 1 2 3) #'<) - (compat--should (list 1 2 3) (list 3 2 1) #'<) - (compat--should '[1 2 3] '[1 2 3] #'<) - (compat--should '[1 2 3] '[3 2 1] #'<))) - -(ert-deftest compat-= () - "Check if `compat--=' was advised correctly." - (compat-test compat-= - (compat--should t 0 0) - (compat--should t 0 0 0) - (compat--should t 0 0 0 0) - (compat--should t 0 0 0 0 0) - (compat--should t 0.0 0.0) - (compat--should t +0.0 -0.0) - (compat--should t 0.0 0.0 0.0) - (compat--should t 0.0 0.0 0.0 0.0) - (compat--should nil 0 1) - (compat--should nil 0 0 1) - (compat--should nil 0 0 0 0 1) - (compat--error wrong-type-argument 0 0 'a) - (compat--should nil 0 1 'a) - (compat--should nil 0.0 0.0 0.0 0.1))) - -(ert-deftest compat-< () - "Check if `compat--<' was advised correctly." - (compat-test compat-< - (compat--should nil 0 0) - (compat--should nil 0 0 0) - (compat--should nil 0 0 0 0) - (compat--should nil 0 0 0 0 0) - (compat--should nil 0.0 0.0) - (compat--should nil +0.0 -0.0) - (compat--should nil 0.0 0.0 0.0) - (compat--should nil 0.0 0.0 0.0 0.0) - (compat--should t 0 1) - (compat--should nil 1 0) - (compat--should nil 0 0 1) - (compat--should t 0 1 2) - (compat--should nil 2 1 0) - (compat--should nil 0 0 0 0 1) - (compat--should t 0 1 2 3 4) - (compat--error wrong-type-argument 0 1 'a) - (compat--should nil 0 0 'a) - (compat--should nil 0.0 0.0 0.0 0.1) - (compat--should t -0.1 0.0 0.2 0.4) - (compat--should t -0.1 0 0.2 0.4))) - -(ert-deftest compat-> () - "Check if `compat-->' was advised correctly." - (compat-test compat-> - (compat--should nil 0 0) - (compat--should nil 0 0 0) - (compat--should nil 0 0 0 0) - (compat--should nil 0 0 0 0 0) - (compat--should nil 0.0 0.0) - (compat--should nil +0.0 -0.0) - (compat--should nil 0.0 0.0 0.0) - (compat--should nil 0.0 0.0 0.0 0.0) - (compat--should t 1 0) - (compat--should nil 1 0 0) - (compat--should nil 0 1 2) - (compat--should t 2 1 0) - (compat--should nil 1 0 0 0 0) - (compat--should t 4 3 2 1 0) - (compat--should nil 4 3 2 1 1) - (compat--error wrong-type-argument 1 0 'a) - (compat--should nil 0 0 'a) - (compat--should nil 0.1 0.0 0.0 0.0) - (compat--should t 0.4 0.2 0.0 -0.1) - (compat--should t 0.4 0.2 0 -0.1))) - -(ert-deftest compat-<= () - "Check if `compat--<=' was advised correctly." - (compat-test compat-<= - (compat--should t 0 0) - (compat--should t 0 0 0) - (compat--should t 0 0 0 0) - (compat--should t 0 0 0 0 0) - (compat--should t 0.0 0.0) - (compat--should t +0.0 -0.0) - (compat--should t 0.0 0.0 0.0) - (compat--should t 0.0 0.0 0.0 0.0) - (compat--should nil 1 0) - (compat--should nil 1 0 0) - (compat--should t 0 1 2) - (compat--should nil 2 1 0) - (compat--should nil 1 0 0 0 0) - (compat--should nil 4 3 2 1 0) - (compat--should nil 4 3 2 1 1) - (compat--should t 0 1 2 3 4) - (compat--should t 1 1 2 3 4) - (compat--error wrong-type-argument 0 0 'a) - (compat--error wrong-type-argument 0 1 'a) - (compat--should nil 1 0 'a) - (compat--should nil 0.1 0.0 0.0 0.0) - (compat--should t 0.0 0.0 0.0 0.1) - (compat--should t -0.1 0.0 0.2 0.4) - (compat--should t -0.1 0.0 0.0 0.2 0.4) - (compat--should t -0.1 0.0 0 0.2 0.4) - (compat--should t -0.1 0 0.2 0.4) - (compat--should nil 0.4 0.2 0.0 -0.1) - (compat--should nil 0.4 0.2 0.0 0.0 -0.1) - (compat--should nil 0.4 0.2 0 0.0 0.0 -0.1) - (compat--should nil 0.4 0.2 0 -0.1))) - -(ert-deftest compat->= () - "Check if `compat-->=' was implemented correctly." - (compat-test compat->= - (compat--should t 0 0) - (compat--should t 0 0 0) - (compat--should t 0 0 0 0) - (compat--should t 0 0 0 0 0) - (compat--should t 0.0 0.0) - (compat--should t +0.0 -0.0) - (compat--should t 0.0 0.0 0.0) - (compat--should t 0.0 0.0 0.0 0.0) - (compat--should t 1 0) - (compat--should t 1 0 0) - (compat--should nil 0 1 2) - (compat--should t 2 1 0) - (compat--should t 1 0 0 0 0) - (compat--should t 4 3 2 1 0) - (compat--should t 4 3 2 1 1) - (compat--error wrong-type-argument 0 0 'a) - (compat--error wrong-type-argument 1 0 'a) - (compat--should nil 0 1 'a) - (compat--should t 0.1 0.0 0.0 0.0) - (compat--should nil 0.0 0.0 0.0 0.1) - (compat--should nil -0.1 0.0 0.2 0.4) - (compat--should nil -0.1 0.0 0.0 0.2 0.4) - (compat--should nil -0.1 0.0 0 0.2 0.4) - (compat--should nil -0.1 0 0.2 0.4) - (compat--should t 0.4 0.2 0.0 -0.1) - (compat--should t 0.4 0.2 0.0 0.0 -0.1) - (compat--should t 0.4 0.2 0 0.0 0.0 -0.1) - (compat--should t 0.4 0.2 0 -0.1))) - -(ert-deftest compat-special-form-p () - "Check if `compat--special-form-p' was implemented correctly." - (compat-test special-form-p - (compat--should t 'if) - (compat--should t 'cond) - (compat--should nil 'when) - (compat--should nil 'defun) - (compat--should nil '+) - (compat--should nil nil) - (compat--should nil "macro") - (compat--should nil '(macro . +)))) - -(ert-deftest compat-macrop () - "Check if `compat--macrop' was implemented correctly." - (compat-test macrop - (compat--should t 'lambda) - (compat--should t 'defun) - (compat--should t 'defmacro) - (compat--should nil 'defalias) - (compat--should nil 'foobar) - (compat--should nil 'if) - (compat--should nil '+) - (compat--should nil 1) - (compat--should nil nil) - (compat--should nil "macro") - (compat--should t '(macro . +)))) - -(ert-deftest compat-string-suffix-p () - "Check if `compat--string-suffix-p' was implemented correctly." - (compat-test string-suffix-p - (compat--should t "a" "abba") - (compat--should t "ba" "abba") - (compat--should t "abba" "abba") - (compat--should nil "a" "ABBA") - (compat--should nil "bA" "ABBA") - (compat--should nil "aBBA" "ABBA") - (compat--should nil "c" "ABBA") - (compat--should nil "c" "abba") - (compat--should nil "cddc" "abba") - (compat--should nil "aabba" "abba"))) - -(ert-deftest compat-split-string () - "Check if `compat--split-string' was advised correctly." - (compat-test compat-split-string - (compat--should '("a" "b" "c") "a b c") - (compat--should '("..a.." "..b.." "..c..") "..a.. ..b.. ..c..") - (compat--should '("a" "b" "c") "..a.. ..b.. ..c.." nil nil "\\.+"))) - -(ert-deftest compat-delete-consecutive-dups () - "Check if `compat--delete-consecutive-dups' was implemented correctly." - (compat-test delete-consecutive-dups - (compat--should '(1 2 3 4) '(1 2 3 4)) - (compat--should '(1 2 3 4) '(1 2 2 3 4 4)) - (compat--should '(1 2 3 2 4) '(1 2 2 3 2 4 4)))) - -(ert-deftest compat-string-clean-whitespace () - "Check if `compat--string-clean-whitespace' was implemented correctly." - (compat-test string-clean-whitespace - (compat--should "a b c" "a b c") - (compat--should "a b c" " a b c") - (compat--should "a b c" "a b c ") - (compat--should "a b c" "a b c") - (compat--should "a b c" "a b c") - (compat--should "a b c" "a b c") - (compat--should "a b c" " a b c") - (compat--should "a b c" "a b c ") - (compat--should "a b c" " a b c ") - (compat--should "aa bb cc" "aa bb cc") - (compat--should "aa bb cc" " aa bb cc") - (compat--should "aa bb cc" "aa bb cc ") - (compat--should "aa bb cc" "aa bb cc") - (compat--should "aa bb cc" "aa bb cc") - (compat--should "aa bb cc" "aa bb cc") - (compat--should "aa bb cc" " aa bb cc") - (compat--should "aa bb cc" "aa bb cc ") - (compat--should "aa bb cc" " aa bb cc "))) - -(ert-deftest compat-string-fill () - "Check if `compat--string-fill' was implemented correctly." - (compat-test string-fill - (compat--should "a a a a a" "a a a a a" 9) - (compat--should "a a a a a" "a a a a a" 10) - (compat--should "a a a a\na" "a a a a a" 8) - (compat--should "a a a a\na" "a a a a a" 8) - (compat--should "a a\na a\na" "a a a a a" 4) - (compat--should "a\na\na\na\na" "a a a a a" 2) - (compat--should "a\na\na\na\na" "a a a a a" 1))) - -(ert-deftest compat-string-lines () - "Check if `compat--string-lines' was implemented correctly." - (compat-test string-lines - (compat--should '("a" "b" "c") "a\nb\nc") - (compat--should '("a" "b" "c" "") "a\nb\nc\n") - (compat--should '("a" "b" "c") "a\nb\nc\n" t) - (compat--should '("abc" "bcd" "cde") "abc\nbcd\ncde") - (compat--should '(" abc" " bcd " "cde ") " abc\n bcd \ncde "))) - -(ert-deftest compat-string-pad () - "Check if `compat--string-pad' was implemented correctly." - (compat-test string-pad - (compat--should "a " "a" 4) - (compat--should "aaaa" "aaaa" 4) - (compat--should "aaaaaa" "aaaaaa" 4) - (compat--should "a..." "a" 4 ?.) - (compat--should " a" "a" 4 nil t) - (compat--should "...a" "a" 4 ?. t))) - -(ert-deftest compat-string-chop-newline () - "Check if `compat--string-chop-newline' was implemented correctly." - (compat-test string-chop-newline - (compat--should "" "") - (compat--should "" "\n") - (compat--should "aaa" "aaa") - (compat--should "aaa" "aaa\n") - (compat--should "aaa\n" "aaa\n\n"))) - -(ert-deftest compat-macroexpand-1 () - "Check if `compat--macroexpand-1' was implemented correctly." - (compat-test macroexpand-1 - (compat--should '(if a b c) '(if a b c)) - (compat--should '(if a (progn b)) '(when a b)) - (compat--should '(if a (progn (unless b c))) '(when a (unless b c))))) - -(ert-deftest compat-file-size-human-readable () - "Check if `compat--file-size-human-readable' was advised properly." - (compat-test compat-file-size-human-readable - (compat--should "1000" 1000) - (compat--should "1k" 1024) - (compat--should "1M" (* 1024 1024)) - (compat--should "1G" (expt 1024 3)) - (compat--should "1T" (expt 1024 4)) - (compat--should "1k" 1000 'si) - (compat--should "1KiB" 1024 'iec) - (compat--should "1KiB" 1024 'iec) - (compat--should "1 KiB" 1024 'iec " ") - (compat--should "1KiA" 1024 'iec nil "A") - (compat--should "1 KiA" 1024 'iec " " "A") - (compat--should "1kA" 1000 'si nil "A") - (compat--should "1 k" 1000 'si " ") - (compat--should "1 kA" 1000 'si " " "A"))) - -(ert-deftest compat-format-prompt () - "Check if `compat--file-size-human-readable' was implemented properly." - (compat-test format-prompt - (compat--should "Prompt: " "Prompt" nil) - (compat--should "Prompt (default 3): " "Prompt" 3) - (compat--should "Prompt (default abc): " "Prompt" "abc") - (compat--should "Prompt (default abc def): " "Prompt" "abc def") - (compat--should "Prompt 10: " "Prompt %d" nil 10) - (compat--should "Prompt \"abc\" (default 3): " "Prompt %S" 3 "abc"))) +(compat-deftests caaar + (ought nil ()) + (ought 'a compat-cXXXr-test)) + +(compat-deftests caadr + (ought nil ()) + (ought 'e compat-cXXXr-test)) + +(compat-deftests cadar + (ought nil ()) + (ought 'c compat-cXXXr-test)) + +(compat-deftests caddr + (ought nil ()) + (ought 'g compat-cXXXr-test)) + +(compat-deftests cdaar + (ought nil ()) + (ought 'b compat-cXXXr-test)) + +(compat-deftests cdadr + (ought nil ()) + (ought 'f compat-cXXXr-test)) + +(compat-deftests cddar + (ought nil ()) + (ought 'd compat-cXXXr-test)) + +(compat-deftests cdddr + (ought nil ()) + (ought 'h compat-cXXXr-test) + #'cdddr) + +(compat-deftests caaaar + (ought nil ()) + (ought 'a compat-cXXXXr-test)) + +(compat-deftests caaadr + (ought nil ()) + (ought 'i compat-cXXXXr-test)) + +(compat-deftests caadar + (ought nil ()) + (ought 'e compat-cXXXXr-test)) + +(compat-deftests caaddr + (ought nil ()) + (ought 'm compat-cXXXXr-test)) + +(compat-deftests cadaar + (ought nil ()) + (ought 'c compat-cXXXXr-test)) + +(compat-deftests cadadr + (ought nil ()) + (ought 'k compat-cXXXXr-test)) + +(compat-deftests caddar + (ought nil ()) + (ought 'g compat-cXXXXr-test)) + +(compat-deftests cadddr + (ought nil ()) + (ought 'o compat-cXXXXr-test)) + +(compat-deftests cdaaar + (ought nil ()) + (ought 'b compat-cXXXXr-test)) + +(compat-deftests cdaadr + (ought nil ()) + (ought 'j compat-cXXXXr-test)) + +(compat-deftests cdadar + (ought nil ()) + (ought 'f compat-cXXXXr-test)) + +(compat-deftests cdaddr + (ought nil ()) + (ought 'j compat-cXXXXr-test)) + +(compat-deftests cddaar + (ought nil ()) + (ought 'd compat-cXXXXr-test)) + +(compat-deftests cddadr + (ought nil ()) + (ought 'l compat-cXXXXr-test)) + +(compat-deftests cdddar + (ought nil ()) + (ought 'h compat-cXXXXr-test)) + +(compat-deftests string-greaterp + (ought t "b" "a") + (ought nil "a" "b") + (ought t "aaab" "aaaa") + (ought nil "aaaa" "aaab")) + +(compat-deftests compat-sort + (ought (list 1 2 3) (list 1 2 3) #'<) + (ought (list 1 2 3) (list 3 2 1) #'<) + (ought '[1 2 3] '[1 2 3] #'<) + (ought '[1 2 3] '[3 2 1] #'<)) + +(compat-deftests compat-= + (ought t 0 0) + (ought t 0 0 0) + (ought t 0 0 0 0) + (ought t 0 0 0 0 0) + (ought t 0.0 0.0) + (ought t +0.0 -0.0) + (ought t 0.0 0.0 0.0) + (ought t 0.0 0.0 0.0 0.0) + (ought nil 0 1) + (ought nil 0 0 1) + (ought nil 0 0 0 0 1) + (expect wrong-type-argument 0 0 'a) + (ought nil 0 1 'a) + (ought nil 0.0 0.0 0.0 0.1)) + +(compat-deftests compat-< + (ought nil 0 0) + (ought nil 0 0 0) + (ought nil 0 0 0 0) + (ought nil 0 0 0 0 0) + (ought nil 0.0 0.0) + (ought nil +0.0 -0.0) + (ought nil 0.0 0.0 0.0) + (ought nil 0.0 0.0 0.0 0.0) + (ought t 0 1) + (ought nil 1 0) + (ought nil 0 0 1) + (ought t 0 1 2) + (ought nil 2 1 0) + (ought nil 0 0 0 0 1) + (ought t 0 1 2 3 4) + (expect wrong-type-argument 0 1 'a) + (ought nil 0 0 'a) + (ought nil 0.0 0.0 0.0 0.1) + (ought t -0.1 0.0 0.2 0.4) + (ought t -0.1 0 0.2 0.4)) + +(compat-deftests compat-> + (ought nil 0 0) + (ought nil 0 0 0) + (ought nil 0 0 0 0) + (ought nil 0 0 0 0 0) + (ought nil 0.0 0.0) + (ought nil +0.0 -0.0) + (ought nil 0.0 0.0 0.0) + (ought nil 0.0 0.0 0.0 0.0) + (ought t 1 0) + (ought nil 1 0 0) + (ought nil 0 1 2) + (ought t 2 1 0) + (ought nil 1 0 0 0 0) + (ought t 4 3 2 1 0) + (ought nil 4 3 2 1 1) + (expect wrong-type-argument 1 0 'a) + (ought nil 0 0 'a) + (ought nil 0.1 0.0 0.0 0.0) + (ought t 0.4 0.2 0.0 -0.1) + (ought t 0.4 0.2 0 -0.1)) + +(compat-deftests compat-<= + (ought t 0 0) + (ought t 0 0 0) + (ought t 0 0 0 0) + (ought t 0 0 0 0 0) + (ought t 0.0 0.0) + (ought t +0.0 -0.0) + (ought t 0.0 0.0 0.0) + (ought t 0.0 0.0 0.0 0.0) + (ought nil 1 0) + (ought nil 1 0 0) + (ought t 0 1 2) + (ought nil 2 1 0) + (ought nil 1 0 0 0 0) + (ought nil 4 3 2 1 0) + (ought nil 4 3 2 1 1) + (ought t 0 1 2 3 4) + (ought t 1 1 2 3 4) + (expect wrong-type-argument 0 0 'a) + (expect wrong-type-argument 0 1 'a) + (ought nil 1 0 'a) + (ought nil 0.1 0.0 0.0 0.0) + (ought t 0.0 0.0 0.0 0.1) + (ought t -0.1 0.0 0.2 0.4) + (ought t -0.1 0.0 0.0 0.2 0.4) + (ought t -0.1 0.0 0 0.2 0.4) + (ought t -0.1 0 0.2 0.4) + (ought nil 0.4 0.2 0.0 -0.1) + (ought nil 0.4 0.2 0.0 0.0 -0.1) + (ought nil 0.4 0.2 0 0.0 0.0 -0.1) + (ought nil 0.4 0.2 0 -0.1)) + +(compat-deftests compat->= + (ought t 0 0) + (ought t 0 0 0) + (ought t 0 0 0 0) + (ought t 0 0 0 0 0) + (ought t 0.0 0.0) + (ought t +0.0 -0.0) + (ought t 0.0 0.0 0.0) + (ought t 0.0 0.0 0.0 0.0) + (ought t 1 0) + (ought t 1 0 0) + (ought nil 0 1 2) + (ought t 2 1 0) + (ought t 1 0 0 0 0) + (ought t 4 3 2 1 0) + (ought t 4 3 2 1 1) + (expect wrong-type-argument 0 0 'a) + (expect wrong-type-argument 1 0 'a) + (ought nil 0 1 'a) + (ought t 0.1 0.0 0.0 0.0) + (ought nil 0.0 0.0 0.0 0.1) + (ought nil -0.1 0.0 0.2 0.4) + (ought nil -0.1 0.0 0.0 0.2 0.4) + (ought nil -0.1 0.0 0 0.2 0.4) + (ought nil -0.1 0 0.2 0.4) + (ought t 0.4 0.2 0.0 -0.1) + (ought t 0.4 0.2 0.0 0.0 -0.1) + (ought t 0.4 0.2 0 0.0 0.0 -0.1) + (ought t 0.4 0.2 0 -0.1)) + +(compat-deftests special-form-p + (ought t 'if) + (ought t 'cond) + (ought nil 'when) + (ought nil 'defun) + (ought nil '+) + (ought nil nil) + (ought nil "macro") + (ought nil '(macro . +))) + +(compat-deftests macrop + (ought t 'lambda) + (ought t 'defun) + (ought t 'defmacro) + (ought nil 'defalias) + (ought nil 'foobar) + (ought nil 'if) + (ought nil '+) + (ought nil 1) + (ought nil nil) + (ought nil "macro") + (ought t '(macro . +))) + +(compat-deftests string-suffix-p + (ought t "a" "abba") + (ought t "ba" "abba") + (ought t "abba" "abba") + (ought nil "a" "ABBA") + (ought nil "bA" "ABBA") + (ought nil "aBBA" "ABBA") + (ought nil "c" "ABBA") + (ought nil "c" "abba") + (ought nil "cddc" "abba") + (ought nil "aabba" "abba")) + +(compat-deftests compat-split-string + (ought '("a" "b" "c") "a b c") + (ought '("..a.." "..b.." "..c..") "..a.. ..b.. ..c..") + (ought '("a" "b" "c") "..a.. ..b.. ..c.." nil nil "\\.+")) + +(compat-deftests delete-consecutive-dups + (ought '(1 2 3 4) '(1 2 3 4)) + (ought '(1 2 3 4) '(1 2 2 3 4 4)) + (ought '(1 2 3 2 4) '(1 2 2 3 2 4 4))) + +(compat-deftests string-clean-whitespace + (ought "a b c" "a b c") + (ought "a b c" " a b c") + (ought "a b c" "a b c ") + (ought "a b c" "a b c") + (ought "a b c" "a b c") + (ought "a b c" "a b c") + (ought "a b c" " a b c") + (ought "a b c" "a b c ") + (ought "a b c" " a b c ") + (ought "aa bb cc" "aa bb cc") + (ought "aa bb cc" " aa bb cc") + (ought "aa bb cc" "aa bb cc ") + (ought "aa bb cc" "aa bb cc") + (ought "aa bb cc" "aa bb cc") + (ought "aa bb cc" "aa bb cc") + (ought "aa bb cc" " aa bb cc") + (ought "aa bb cc" "aa bb cc ") + (ought "aa bb cc" " aa bb cc ")) + +(compat-deftests string-fill + (ought "a a a a a" "a a a a a" 9) + (ought "a a a a a" "a a a a a" 10) + (ought "a a a a\na" "a a a a a" 8) + (ought "a a a a\na" "a a a a a" 8) + (ought "a a\na a\na" "a a a a a" 4) + (ought "a\na\na\na\na" "a a a a a" 2) + (ought "a\na\na\na\na" "a a a a a" 1)) + +(compat-deftests string-lines + (ought '("a" "b" "c") "a\nb\nc") + (ought '("a" "b" "c" "") "a\nb\nc\n") + (ought '("a" "b" "c") "a\nb\nc\n" t) + (ought '("abc" "bcd" "cde") "abc\nbcd\ncde") + (ought '(" abc" " bcd " "cde ") " abc\n bcd \ncde ")) + +(compat-deftests string-pad + (ought "a " "a" 4) + (ought "aaaa" "aaaa" 4) + (ought "aaaaaa" "aaaaaa" 4) + (ought "a..." "a" 4 ?.) + (ought " a" "a" 4 nil t) + (ought "...a" "a" 4 ?. t)) + +(compat-deftests string-chop-newline + (ought "" "") + (ought "" "\n") + (ought "aaa" "aaa") + (ought "aaa" "aaa\n") + (ought "aaa\n" "aaa\n\n")) + +(compat-deftests macroexpand-1 + (ought '(if a b c) '(if a b c)) + (ought '(if a (progn b)) '(when a b)) + (ought '(if a (progn (unless b c))) '(when a (unless b c)))) + +(compat-deftests compat-file-size-human-readable + (ought "1000" 1000) + (ought "1k" 1024) + (ought "1M" (* 1024 1024)) + (ought "1G" (expt 1024 3)) + (ought "1T" (expt 1024 4)) + (ought "1k" 1000 'si) + (ought "1KiB" 1024 'iec) + (ought "1KiB" 1024 'iec) + (ought "1 KiB" 1024 'iec " ") + (ought "1KiA" 1024 'iec nil "A") + (ought "1 KiA" 1024 'iec " " "A") + (ought "1kA" 1000 'si nil "A") + (ought "1 k" 1000 'si " ") + (ought "1 kA" 1000 'si " " "A")) + +(compat-deftests format-prompt + (ought "Prompt: " "Prompt" nil) + (ought "Prompt: " "Prompt" "") + (ought "Prompt (default ): " "Prompt" " ") + (ought "Prompt (default 3): " "Prompt" 3) + (ought "Prompt (default abc): " "Prompt" "abc") + (ought "Prompt (default abc def): " "Prompt" "abc def") + (ought "Prompt 10: " "Prompt %d" nil 10) + (ought "Prompt \"abc\" (default 3): " "Prompt %S" 3 "abc")) (ert-deftest compat-named-let () "Check if `compat--named-let' was implemented properly." @@ -1193,65 +1147,59 @@ the compatibility function." 100000)) (should (= (compat--named-let l ((i 0) (x 1)) (if (= i 8) x (l (1+ i) (* x 2)))) (expt 2 8))) - (should (eq (compat--named-let loop ((x 1)) + (should (eq (compat--named-let lop ((x 1)) (if (> x 0) (condition-case nil - (loop (1- x)) + (lop (1- x)) (arith-error 'ok)) (/ 1 x))) 'ok)) - (should (eq (compat--named-let loop ((n 10000)) + (should (eq (compat--named-let lop ((n 10000)) (if (> n 0) (condition-case nil (/ n 0) - (arith-error (loop (1- n)))) + (arith-error (lop (1- n)))) 'ok)) 'ok)) - (should (eq (compat--named-let loop ((x nil)) + (should (eq (compat--named-let lop ((x nil)) (cond (x) (t 'ok))) 'ok)) - (should (eq (compat--named-let loop ((x 100000)) + (should (eq (compat--named-let lop ((x 100000)) (cond ((= x 0) 'ok) - ((loop (1- x))))) + ((lop (1- x))))) 'ok)) - (should (eq (compat--named-let loop ((x 100000)) + (should (eq (compat--named-let lop ((x 100000)) (cond ((= x -1) nil) ((= x 0) 'ok) - ((loop -1)) - ((loop (1- x))))) + ((lop -1)) + ((lop (1- x))))) 'ok)) - (should (eq (compat--named-let loop ((x 10000)) + (should (eq (compat--named-let lop ((x 10000)) (cond ((= x 0) 'ok) - ((and t (loop (1- x)))))) + ((and t (lop (1- x)))))) 'ok)) - (should (eq (eval - (let ((branch '((loop (and (setq b (not b)) (1+ i)))))) - `(let ((b t)) - (compat--named-let loop ((i 0)) - (cond ((null i) nil) - ((= i 10000) 'ok) - ,branch - ,branch)))) - t) + (should (eq (let ((b t)) + (compat--named-let lop ((i 0)) + (cond ((null i) nil) ((= i 10000) 'ok) + ((lop (and (setq b (not b)) (1+ i)))) + ((lop (and (setq b (not b)) (1+ i))))))) 'ok))) -(ert-deftest compat-directory-name-p () - "Check if `compat--directory-name-p' was implemented properly." - (compat-test directory-name-p - (compat--should t "/") - (compat--should nil "/file") - (compat--should nil "/dir/file") - (compat--should t "/dir/") - (compat--should nil "/dir") - (compat--should t "/dir/subdir/") - (compat--should nil "/dir/subdir") - (compat--should t "dir/") - (compat--should nil "file") - (compat--should nil "dir/file") - (compat--should t "dir/subdir/") - (compat--should nil "dir/subdir"))) +(compat-deftests directory-name-p + (ought t "/") + (ought nil "/file") + (ought nil "/dir/file") + (ought t "/dir/") + (ought nil "/dir") + (ought t "/dir/subdir/") + (ought nil "/dir/subdir") + (ought t "dir/") + (ought nil "file") + (ought nil "dir/file") + (ought t "dir/subdir/") + (ought nil "dir/subdir")) (ert-deftest compat-if-let* () "Check if `compat--if-let*' was implemented properly." @@ -1266,8 +1214,21 @@ the compatibility function." (should-not (compat--if-let* (((= 5 6))) t nil))) +(ert-deftest compat-if-let () + "Check if `compat--if-let' was implemented properly." + (should (compat--if-let ((e (memq 0 '(1 2 3 0 5 6)))) + e)) + (should-not (compat--if-let ((e (memq 0 '(1 2 3 5 6))) + (d (memq 0 '(1 2 3 0 5 6)))) + t)) + (should-not (compat--if-let ((d (memq 0 '(1 2 3 0 5 6))) + (e (memq 0 '(1 2 3 5 6)))) + t)) + (should-not + (compat--if-let (((= 5 6))) t nil))) + (ert-deftest compat-and-let* () - "Check if `compat--if-let*' was implemented properly." + "Check if `compat--and-let*' was implemented properly." (should ;trivial body (compat--and-let* ((x 3) @@ -1286,21 +1247,19 @@ the compatibility function." (should-not (compat--and-let* (((= 5 6))) t))) +(compat-deftests compat-json-parse-string + (ought 0 "0") + (ought 1 "1") + (ought 0.5 "0.5") + (ought [1 2 3] "[1,2,3]") + (ought ["a" 2 3] "[\"a\",2,3]") + (ought [["a" 2] 3] "[[\"a\",2],3]") + (ought '(("a" 2) 3) "[[\"a\",2],3]" :array-type 'list) + (ought 'foo "null" :null-object 'foo) + (ought ["false" t] "[false, true]" :false-object "false")) + (ert-deftest compat-json-parse-string () "Check if `compat--json-parse-string' was implemented properly." - (compat-test (json-parse-string (if (version<= "28" emacs-version) - (apply-partially #'compat--json-parse-string-handle-tlo - #'json-parse-string) - #'compat--json-parse-string)) - (compat--should 0 "0") - (compat--should 1 "1") - (compat--should 0.5 "0.5") - (compat--should [1 2 3] "[1,2,3]") - (compat--should ["a" 2 3] "[\"a\",2,3]") - (compat--should [["a" 2] 3] "[[\"a\",2],3]") - (compat--should '(("a" 2) 3) "[[\"a\",2],3]" :array-type 'list) - (compat--should 'foo "null" :null-object 'foo) - (compat--should ["false" t] "[false, true]" :false-object "false")) (let ((input "{\"key\":[\"abc\", 2], \"yek\": null}")) (let ((obj (compat--json-parse-string input))) (should (equal (gethash "key" obj) ["abc" 2])) @@ -1322,17 +1281,558 @@ the compatibility function." (should (equal (gethash "key" obj) ["abc" 2])) (should (equal (gethash "yek" obj) :null)))))) -(ert-deftest compat-lookup-key () - "Check if `compat-lookup-key' was implemented properly." +(ert-deftest compat-json-serialize () + "Check if `compat--json-serialize' was implemented properly." + (let ((input-1 '((:key . ["abc" 2]) (yek . t))) + (input-2 '(:key ["abc" 2] yek t)) + (input-3 (let ((ht (make-hash-table))) + (puthash "key" ["abc" 2] ht) + (puthash "yek" t ht) + ht))) + (should (equal (compat--json-serialize input-1) + "{\":key\":[\"abc\",2],\"yek\":true}")) + (should (equal (compat--json-serialize input-2) + "{\"key\":[\"abc\",2],\"yek\":true}")) + (should (member (compat--json-serialize input-2) + '("{\"key\":[\"abc\",2],\"yek\":true}" + "{\"yek\":true,\"key\":[\"abc\",2]}"))) + (should-error (compat--json-serialize '(("a" . 1))) + :type '(wrong-type-argument symbolp "a")) + (should-error (compat--json-serialize '("a" 1)) + :type '(wrong-type-argument symbolp "a")) + (should-error (compat--json-serialize '("a" 1 2)) + :type '(wrong-type-argument symbolp "a")) + (should-error (compat--json-serialize '(:a 1 2)) + :type '(wrong-type-argument consp nil)) + (should-error (compat--json-serialize + (let ((ht (make-hash-table))) + (puthash 'a 1 ht) + ht)) + :type '(wrong-type-argument stringp a)) + (when (fboundp 'json-serialize) + (should (equal (json-serialize input-1) + "{\":key\":[\"abc\",2],\"yek\":true}")) + (should (equal (json-serialize input-2) + "{\"key\":[\"abc\",2],\"yek\":true}")) + (should (member (json-serialize input-2) + '("{\"key\":[\"abc\",2],\"yek\":true}" + "{\"yek\":true,\"key\":[\"abc\",2]}"))) + (should-error (json-serialize '(("a" . 1))) + :type '(wrong-type-argument symbolp "a")) + (should-error (json-serialize '("a" 1)) + :type '(wrong-type-argument symbolp "a")) + (should-error (json-serialize '("a" 1 2)) + :type '(wrong-type-argument symbolp "a")) + (should-error (json-serialize '(:a 1 2)) + :type '(wrong-type-argument consp nil)) + (should-error (json-serialize + (let ((ht (make-hash-table))) + (puthash 'a 1 ht) + ht)) + :type '(wrong-type-argument stringp a))))) + +(compat-deftests compat-lookup-key (let ((a-map (make-sparse-keymap)) (b-map (make-sparse-keymap))) (define-key a-map "x" 'foo) (define-key b-map "x" 'bar) - (compat-test compat-lookup-key - (compat--should 'foo a-map "x") - (compat--should 'bar b-map "x") - (compat--should 'foo (list a-map b-map) "x") - (compat--should 'bar (list b-map a-map) "x")))) + (ought 'foo a-map "x") + (ought 'bar b-map "x") + (ought 'foo (list a-map b-map) "x") + (ought 'bar (list b-map a-map) "x"))) + +(ert-deftest compat-hash-table-keys () + (let ((ht (make-hash-table))) + (should (null (compat--hash-table-keys ht))) + (puthash 1 'one ht) + (should (equal '(1) (compat--hash-table-keys ht))) + (puthash 1 'one ht) + (should (equal '(1) (compat--hash-table-keys ht))) + (puthash 2 'two ht) + (should (memq 1 (compat--hash-table-keys ht))) + (should (memq 2 (compat--hash-table-keys ht))) + (should (= 2 (length (compat--hash-table-keys ht)))) + (remhash 1 ht) + (should (equal '(2) (compat--hash-table-keys ht))))) + +(ert-deftest compat-hash-table-values () + (let ((ht (make-hash-table))) + (should (null (compat--hash-table-values ht))) + (puthash 1 'one ht) + (should (equal '(one) (compat--hash-table-values ht))) + (puthash 1 'one ht) + (should (equal '(one) (compat--hash-table-values ht))) + (puthash 2 'two ht) + (should (memq 'one (compat--hash-table-values ht))) + (should (memq 'two (compat--hash-table-values ht))) + (should (= 2 (length (compat--hash-table-values ht)))) + (remhash 1 ht) + (should (equal '(two) (compat--hash-table-values ht))))) + +(compat-deftests string-empty-p + (ought t "") + (ought nil " ") + (ought t (make-string 0 ?x)) + (ought nil (make-string 1 ?x))) + +(compat-deftests string-join + (ought "" '("")) + (ought "" '("") " ") + (ought "a" '("a")) + (ought "a" '("a") " ") + (ought "abc" '("a" "b" "c")) + (ought "a b c" '("a" "b" "c") " ")) + +(compat-deftests string-blank-p + (ought 0 "") + (ought 0 " ") + (ought 0 (make-string 0 ?x)) + (ought nil (make-string 1 ?x))) + +(compat-deftests string-remove-prefix + (ought "" "" "") + (ought "a" "" "a") + (ought "" "a" "") + (ought "bc" "a" "abc") + (ought "abc" "c" "abc") + (ought "bbcc" "aa" "aabbcc") + (ought "aabbcc" "bb" "aabbcc") + (ought "aabbcc" "cc" "aabbcc") + (ought "aabbcc" "dd" "aabbcc")) + +(compat-deftests string-remove-suffix + (ought "" "" "") + (ought "a" "" "a") + (ought "" "a" "") + (ought "abc" "a" "abc") + (ought "ab" "c" "abc") + (ought "aabbcc" "aa" "aabbcc") + (ought "aabbcc" "bb" "aabbcc") + (ought "aabb" "cc" "aabbcc") + (ought "aabbcc" "dd" "aabbcc")) + +(let ((a (bool-vector t t nil nil)) + (b (bool-vector t nil t nil))) + (compat-deftests bool-vector-exclusive-or + (ought (bool-vector nil t t nil) a b) + (ought (bool-vector nil t t nil) b a) + (ert-deftest compat-bool-vector-exclusive-or-sideeffect () + (let ((c (make-bool-vector 4 nil))) + (compat--bool-vector-exclusive-or a b c) + (should (equal (bool-vector nil t t nil) c)) + (should (equal (bool-vector nil t t nil) c)))) + (when (version<= "24.4" emacs-version) + (expect wrong-length-argument a (bool-vector)) + (expect wrong-length-argument a b (bool-vector))) + (expect wrong-type-argument (bool-vector) (vector)) + (expect wrong-type-argument (vector) (bool-vector)) + (expect wrong-type-argument (vector) (vector)) + (expect wrong-type-argument (bool-vector) (bool-vector) (vector)) + (expect wrong-type-argument (bool-vector) (vector) (vector)) + (expect wrong-type-argument (vector) (bool-vector) (vector)) + (expect wrong-type-argument (vector) (vector) (vector)))) + +(let ((a (bool-vector t t nil nil)) + (b (bool-vector t nil t nil))) + (compat-deftests bool-vector-union + (ought (bool-vector t t t nil) a b) + (ought (bool-vector t t t nil) b a) + (ert-deftest compat-bool-vector-union-sideeffect () + (let ((c (make-bool-vector 4 nil))) + (compat--bool-vector-union a b c) + (should (equal (bool-vector t t t nil) c)))) + (when (version<= "24.4" emacs-version) + (expect wrong-length-argument a (bool-vector)) + (expect wrong-length-argument a b (bool-vector))) + (expect wrong-type-argument (bool-vector) (vector)) + (expect wrong-type-argument (vector) (bool-vector)) + (expect wrong-type-argument (vector) (vector)) + (expect wrong-type-argument (bool-vector) (bool-vector) (vector)) + (expect wrong-type-argument (bool-vector) (vector) (vector)) + (expect wrong-type-argument (vector) (bool-vector) (vector)) + (expect wrong-type-argument (vector) (vector) (vector)))) + +(let ((a (bool-vector t t nil nil)) + (b (bool-vector t nil t nil))) + (compat-deftests bool-vector-intersection + (ought (bool-vector t nil nil nil) a b) + (ought (bool-vector t nil nil nil) b a) + (ert-deftest compat-bool-vector-intersection-sideeffect () + (let ((c (make-bool-vector 4 nil))) + (compat--bool-vector-intersection a b c) + (should (equal (bool-vector t nil nil nil) c)))) + (when (version<= "24.4" emacs-version) + (expect wrong-length-argument a (bool-vector)) + (expect wrong-length-argument a b (bool-vector))) + (expect wrong-type-argument (bool-vector) (vector)) + (expect wrong-type-argument (vector) (bool-vector)) + (expect wrong-type-argument (vector) (vector)) + (expect wrong-type-argument (bool-vector) (bool-vector) (vector)) + (expect wrong-type-argument (bool-vector) (vector) (vector)) + (expect wrong-type-argument (vector) (bool-vector) (vector)) + (expect wrong-type-argument (vector) (vector) (vector)))) + +(let ((a (bool-vector t t nil nil)) + (b (bool-vector t nil t nil))) + (compat-deftests bool-vector-set-difference + (ought (bool-vector nil t nil nil) a b) + (ought (bool-vector nil nil t nil) b a) + (ert-deftest compat-bool-vector-set-difference-sideeffect () + (let ((c (make-bool-vector 4 nil))) + (compat--bool-vector-set-difference a b c) + (should (equal (bool-vector nil t nil nil) c))) + (let ((c (make-bool-vector 4 nil))) + (compat--bool-vector-set-difference b a c) + (should (equal (bool-vector nil nil t nil) c)))) + (when (version<= "24.4" emacs-version) + (expect wrong-length-argument a (bool-vector)) + (expect wrong-length-argument a b (bool-vector))) + (expect wrong-type-argument (bool-vector) (vector)) + (expect wrong-type-argument (vector) (bool-vector)) + (expect wrong-type-argument (vector) (vector)) + (expect wrong-type-argument (bool-vector) (bool-vector) (vector)) + (expect wrong-type-argument (bool-vector) (vector) (vector)) + (expect wrong-type-argument (vector) (bool-vector) (vector)) + (expect wrong-type-argument (vector) (vector) (vector)))) + +(compat-deftests bool-vector-not + (ought (bool-vector) (bool-vector)) + (ought (bool-vector t) (bool-vector nil)) + (ought (bool-vector nil) (bool-vector t)) + (ought (bool-vector t t) (bool-vector nil nil)) + (ought (bool-vector t nil) (bool-vector nil t)) + (ought (bool-vector nil t) (bool-vector t nil)) + (ought (bool-vector nil nil) (bool-vector t t)) + (expect wrong-type-argument (vector)) + (expect wrong-type-argument (vector) (vector))) + +(compat-deftests bool-vector-subsetp + (ought t (bool-vector) (bool-vector)) + (ought t (bool-vector t) (bool-vector t)) + (ought t (bool-vector nil) (bool-vector t)) + (ought nil (bool-vector t) (bool-vector nil)) + (ought t (bool-vector nil) (bool-vector nil)) + (ought t (bool-vector t t) (bool-vector t t)) + (ought t (bool-vector nil nil) (bool-vector t t)) + (ought t (bool-vector nil nil) (bool-vector t nil)) + (ought t (bool-vector nil nil) (bool-vector nil t)) + (ought nil (bool-vector t nil) (bool-vector nil nil)) + (ought nil (bool-vector nil t) (bool-vector nil nil)) + (when (version<= "24.4" emacs-version) + (expect wrong-length-argument (bool-vector nil) (bool-vector nil nil))) + (expect wrong-type-argument (bool-vector) (vector)) + (expect wrong-type-argument (vector) (bool-vector)) + (expect wrong-type-argument (vector) (vector))) + +(compat-deftests bool-vector-count-consecutive + (ought 0 (bool-vector nil) (bool-vector nil) 0) + (ought 0 (make-bool-vector 10 nil) t 0) + (ought 10 (make-bool-vector 10 nil) nil 0) + (ought 0 (make-bool-vector 10 nil) t 1) + (ought 9 (make-bool-vector 10 nil) nil 1) + (ought 0 (make-bool-vector 10 nil) t 1) + (ought 9 (make-bool-vector 10 t) t 1) + (ought 0 (make-bool-vector 10 nil) t 8) + (ought 2 (make-bool-vector 10 nil) nil 8) + (ought 2 (make-bool-vector 10 t) t 8) + (ought 10 (make-bool-vector 10 t) (make-bool-vector 10 t) 0) + (ought 4 (bool-vector t t t t nil t t t t t) t 0) + (ought 0 (bool-vector t t t t nil t t t t t) t 4) + (ought 5 (bool-vector t t t t nil t t t t t) t 5) + (expect wrong-type-argument (vector) nil 0)) + +(compat-deftests bool-vector-count-population + (ought 0 (bool-vector)) + (ought 0 (make-bool-vector 10 nil)) + (ought 10 (make-bool-vector 10 t)) + (ought 1 (bool-vector nil nil t nil)) + (ought 1 (bool-vector nil nil nil t)) + (ought 1 (bool-vector t nil nil nil)) + (ought 2 (bool-vector t nil nil t)) + (ought 2 (bool-vector t nil t nil)) + (ought 3 (bool-vector t nil t t)) + (expect wrong-type-argument (vector))) + +(compat-deftests compat-assoc-delete-all + (ought (list) 0 (list)) + ;; Test `eq' + (ought '((1 . one)) 0 (list (cons 1 'one))) + (ought '((1 . one) a) 0 (list (cons 1 'one) 'a)) + (ought '((1 . one)) 0 (list (cons 0 'zero) (cons 1 'one))) + (ought '((1 . one)) 0 (list (cons 0 'zero) (cons 0 'zero) (cons 1 'one))) + (ought '((1 . one)) 0 (list (cons 0 'zero) (cons 1 'one) (cons 0 'zero))) + (ought '((1 . one) a) 0 (list (cons 0 'zero) (cons 1 'one) 'a (cons 0 'zero))) + (ought '(a (1 . one)) 0 (list 'a (cons 0 'zero) (cons 1 'one) (cons 0 'zero))) + ;; Test `equal' + (ought '(("one" . one)) "zero" (list (cons "one" 'one))) + (ought '(("one" . one) a) "zero" (list (cons "one" 'one) 'a)) + (ought '(("one" . one)) "zero" (list (cons "zero" 'zero) (cons "one" 'one))) + (ought '(("one" . one)) "zero" (list (cons "zero" 'zero) (cons "zero" 'zero) (cons "one" 'one))) + (ought '(("one" . one)) "zero" (list (cons "zero" 'zero) (cons "one" 'one) (cons "zero" 'zero))) + (ought '(("one" . one) a) "zero" (list (cons "zero" 'zero) (cons "one" 'one) 'a (cons "zero" 'zero))) + (ought '(a ("one" . one)) "zero" (list 'a (cons "zero" 'zero) (cons "one" 'one) (cons "zero" 'zero))) + ;; Test custom predicate + (ought '() 0 (list (cons 1 'one)) #'/=) + (ought '(a) 0 (list (cons 1 'one) 'a) #'/=) + (ought '((0 . zero)) 0 (list (cons 0 'zero) (cons 1 'one)) #'/=) + (ought '((0 . zero) (0 . zero)) 0 (list (cons 0 'zero) (cons 0 'zero) (cons 1 'one)) #'/=) + (ought '((0 . zero) (0 . zero)) 0 (list (cons 0 'zero) (cons 1 'one) (cons 0 'zero)) #'/=) + (ought '((0 . zero) a (0 . zero)) 0 (list (cons 0 'zero) (cons 1 'one) 'a (cons 0 'zero)) #'/=) + (ought '(a (0 . zero) (0 . zero)) 0 (list 'a (cons 0 'zero) (cons 1 'one) (cons 0 'zero)) #'/=)) + +(compat-deftests color-values-from-color-spec + ;; #RGB notation + (ought '(0 0 0) "#000") + (ought '(0 0 0) "#000000") + (ought '(0 0 0) "#000000000") + (ought '(0 0 0) "#000000000000") + (ought '(0 0 65535) "#00F") + (ought '(0 0 65535) "#0000FF") + (ought '(0 0 65535) "#000000FFF") + (ought '(0 0 65535) "#00000000FFFF") + (ought '(0 0 65535) "#00f") + (ought '(0 0 65535) "#0000ff") + (ought '(0 0 65535) "#000000fff") + (ought '(0 0 65535) "#00000000ffff") + (ought '(0 0 65535) "#00000000ffFF") + (ought '(#xffff #x0000 #x5555) "#f05") + (ought '(#x1f1f #xb0b0 #xc5c5) "#1fb0C5") + (ought '(#x1f83 #xb0ad #xc5e2) "#1f83b0ADC5e2") + (ought nil "") + (ought nil "#") + (ought nil "#0") + (ought nil "#00") + (ought nil "#0000FG") + (ought nil "#0000FFF") + (ought nil "#0000FFFF") + (ought '(0 4080 65535) "#0000FFFFF") + (ought nil "#000FF") + (ought nil "#0000F") + (ought nil " #000000") + (ought nil "#000000 ") + (ought nil " #000000 ") + (ought nil "#1f83b0ADC5e2g") + (ought nil "#1f83b0ADC5e20") + (ought nil "#12345") + ;; rgb: notation + (ought '(0 0 0) "rgb:0/0/0") + (ought '(0 0 0) "rgb:0/0/00") + (ought '(0 0 0) "rgb:0/00/000") + (ought '(0 0 0) "rgb:0/000/0000") + (ought '(0 0 0) "rgb:000/0000/0") + (ought '(0 0 65535) "rgb:000/0000/F") + (ought '(65535 0 65535) "rgb:FFF/0000/F") + (ought '(65535 0 65535) "rgb:FFFF/0000/FFFF") + (ought '(0 255 65535) "rgb:0/00FF/FFFF") + (ought '(#xffff #x2323 #x28a2) "rgb:f/23/28a") + (ought '(#x1234 #x5678 #x09ab) "rgb:1234/5678/09ab") + (ought nil "rgb:/0000/FFFF") + (ought nil "rgb:0000/0000/FFFG") + (ought nil "rgb:0000/0000/FFFFF") + (ought nil "rgb:0000/0000") + (ought nil "rg:0000/0000/0000") + (ought nil "rgb: 0000/0000/0000") + (ought nil "rgbb:0000/0000/0000") + (ought nil "rgb:0000/0000/0000 ") + (ought nil " rgb:0000/0000/0000 ") + (ought nil " rgb:0000/0000/0000") + (ought nil "rgb:0000/ 0000 /0000") + (ought nil "rgb: 0000 /0000 /0000") + (ought nil "rgb:0//0") + ;; rgbi: notation + (ought '(0 0 0) "rgbi:0/0/0") + (ought '(0 0 0) "rgbi:0.0/0.0/0.0") + (ought '(0 0 0) "rgbi:0.0/0/0") + (ought '(0 0 0) "rgbi:0.0/0/0") + (ought '(0 0 0) "rgbi:0/0/0.") + (ought '(0 0 0) "rgbi:0/0/0.0000") + (ought '(0 0 0) "rgbi:0/0/.0") + (ought '(0 0 0) "rgbi:0/0/.0000") + (ought '(65535 0 0) "rgbi:1/0/0.0000") + (ought '(65535 0 0) "rgbi:1./0/0.0000") + (ought '(65535 0 0) "rgbi:1.0/0/0.0000") + (ought '(65535 32768 0) "rgbi:1.0/0.5/0.0000") + (ought '(6554 21843 65469) "rgbi:0.1/0.3333/0.999") + (ought '(0 32768 6554) "rgbi:0/0.5/0.1") + (ought '(66 655 65535) "rgbi:1e-3/1.0e-2/1e0") + (ought '(6554 21843 65469) "rgbi:1e-1/+0.3333/0.00999e2") + (ought nil "rgbi:1.0001/0/0") + (ought nil "rgbi:2/0/0") + (ought nil "rgbi:0.a/0/0") + (ought nil "rgbi:./0/0") + (ought nil "rgbi:./0/0") + (ought nil " rgbi:0/0/0") + (ought nil "rgbi:0/0/0 ") + (ought nil " rgbi:0/0/0 ") + (ought nil "rgbi:0 /0/ 0") + (ought nil "rgbi:0/ 0 /0") + (ought nil "rgbii:0/0/0") + (ought nil "rgbi :0/0/0") + ;; strtod ignores leading whitespace, making these legal colour + ;; specifications: + ;; + ;; (ought nil "rgbi: 0/0/0") + ;; (ought nil "rgbi: 0/ 0/ 0") + (ought nil "rgbi : 0/0/0") + (ought nil "rgbi:0/0.5/10")) + +(compat-deftests file-modes-number-to-symbolic + (ought "-rwx------" #o700) + (ought "-rwxrwx---" #o770) + (ought "-rwx---rwx" #o707) + (ought "-rw-r-xr--" #o654) + (ought "--wx-w---x" #o321) + (ought "drwx------" #o700 ?d) + (ought "?rwx------" #o700 ??) + (ought "lrwx------" #o120700) + (ought "prwx------" #o10700) + (ought "-rwx------" #o30700)) + +(compat-deftests file-local-name + (ought "" "") + (ought "foo" "foo") + (ought "/bar/foo" "/bar/foo") + ;; These tests fails prior to Emacs 26, because /ssh:foo was a valid + ;; TRAMP path back then. + ;; + ;; (ought "/ssh:foo" "/ssh:foo") + ;; (ought "/ssh:/bar/foo" "/ssh:/bar/foo") + (ought "foo" "/ssh::foo") + (ought "/bar/foo" "/ssh::/bar/foo") + (ought ":foo" "/ssh:::foo") + (ought ":/bar/foo" "/ssh:::/bar/foo")) + +(compat-deftests file-name-quoted-p + (ought nil "") + (ought t "/:") + (ought nil "//:") + (ought t "/::") + (ought nil "/ssh::") + (ought nil "/ssh::a") + (ought t "/ssh::/:a") + ;; These tests fails prior to Emacs 26, because /ssh:foo was a valid + ;; TRAMP path back then. + ;; + ;; (ought nil "/ssh:/:a") + ) + +(compat-deftests file-name-quote + (ought "/:" "") + (ought "/::" ":") + (ought "/:/" "/") + (ought "/:" "/:") + (ought "/:a" "a") + (ought "/::a" ":a") + (ought "/:/a" "/a") + (ought "/:a" "/:a") + (ought (concat "/ssh:" (system-name) ":/:a") "/ssh::a")) + +(compat-deftests make-lock-file-name + (ought (expand-file-name ".#") "") + (ought (expand-file-name ".#a") "a") + (ought (expand-file-name ".#foo") "foo") + (ought (expand-file-name ".#.") ".") + (ought (expand-file-name ".#.#") ".#") + (ought (expand-file-name ".#.a") ".a") + (ought (expand-file-name ".#.#") ".#") + (ought (expand-file-name "a/.#") "a/") + (ought (expand-file-name "a/.#b") "a/b") + (ought (expand-file-name "a/.#.#") "a/.#") + (ought (expand-file-name "a/.#.") "a/.") + (ought (expand-file-name "a/.#.b") "a/.b") + (ought (expand-file-name "a/.#foo") "a/foo") + (ought (expand-file-name "bar/.#b") "bar/b") + (ought (expand-file-name "bar/.#foo") "bar/foo")) + +(compat-deftests time-equal-p + (ought t nil nil) + + ;; FIXME: Testing these values can be tricky, because the timestamp + ;; might change between evaluating (current-time) and evaluating + ;; `time-equal-p', especially in the interpreted compatibility + ;; version. + + ;; (ought t (current-time) nil) + ;; (ought t nil (current-time)) + + ;; While `sleep-for' returns nil, indicating the current time, this + ;; behaviour seems to be undefined. Relying on it is therefore not + ;; advised. + (ought nil (current-time) (ignore (sleep-for 0.01))) + (ought nil (current-time) (progn + (sleep-for 0.01) + (current-time))) + (ought t '(1 2 3 4) '(1 2 3 4)) + (ought nil '(1 2 3 4) '(1 2 3 5)) + (ought nil '(1 2 3 5) '(1 2 3 4)) + (ought nil '(1 2 3 4) '(1 2 4 4)) + (ought nil '(1 2 4 4) '(1 2 3 4)) + (ought nil '(1 2 3 4) '(1 3 3 4)) + (ought nil '(1 3 3 4) '(1 2 3 4)) + (ought nil '(1 2 3 4) '(2 2 3 4)) + (ought nil '(2 2 3 4) '(1 2 3 4))) + +(compat-deftests date-days-in-month + (ought 31 2020 1) + (ought 30 2020 4) + (ought 29 2020 2) + (ought 28 2021 2)) + +(compat-deftests decoded-time-period + (ought 0 '()) + (ought 0 '(0)) + (ought 1 '(1)) + (ought 0.125 '((1 . 8))) + + (ought 60 '(0 1)) + (ought 61 '(1 1)) + (ought -59 '(1 -1)) + + (ought (* 60 60) '(0 0 1)) + (ought (+ (* 60 60) 60) '(0 1 1)) + (ought (+ (* 60 60) 120 1) '(1 2 1)) + + (ought (* 60 60 24) '(0 0 0 1)) + (ought (+ (* 60 60 24) 1) '(1 0 0 1)) + (ought (+ (* 60 60 24) (* 60 60) 60 1) '(1 1 1 1)) + (ought (+ (* 60 60 24) (* 60 60) 120 1) '(1 2 1 1)) + + (ought (* 60 60 24 30) '(0 0 0 0 1)) + (ought (+ (* 60 60 24 30) 1) '(1 0 0 0 1)) + (ought (+ (* 60 60 24 30) 60 1) '(1 1 0 0 1)) + (ought (+ (* 60 60 24 30) (* 60 60) 60 1) + '(1 1 1 0 1)) + (ought (+ (* 60 60 24 30) (* 60 60 24) (* 60 60) 120 1) + '(1 2 1 1 1)) + + (ought (* 60 60 24 365) '(0 0 0 0 0 1)) + (ought (+ (* 60 60 24 365) 1) + '(1 0 0 0 0 1)) + (ought (+ (* 60 60 24 365) 60 1) + '(1 1 0 0 0 1)) + (ought (+ (* 60 60 24 365) (* 60 60) 60 1) + '(1 1 1 0 0 1)) + (ought (+ (* 60 60 24 365) (* 60 60 24) (* 60 60) 60 1) + '(1 1 1 1 0 1)) + (ought (+ (* 60 60 24 365) + (* 60 60 24 30) + (* 60 60 24) + (* 60 60) + 120 1) + '(1 2 1 1 1 1)) + + (expect wrong-type-argument 'a) + (expect wrong-type-argument '(0 a)) + (expect wrong-type-argument '(0 0 a)) + (expect wrong-type-argument '(0 0 0 a)) + (expect wrong-type-argument '(0 0 0 0 a)) + (expect wrong-type-argument '(0 0 0 0 0 a))) + +(compat-deftests subr-primitive-p + (ought t (symbol-function 'identity)) ;function from fns.c + (ought nil (symbol-function 'match-string)) ;function from subr.el + (ought nil (symbol-function 'defun)) ;macro from subr.el + (ought nil nil)) (ert-deftest compat-string-limit () "Check if `compat-string-limit' was implemented properly." @@ -1444,5 +1944,20 @@ the compatibility function." (compat--should nil 5 'bold) (compat--should nil 8 'width)))) +(compat-deftests file-name-absolute-p ;assuming unix + (ought t "/") + (ought t "/a") + (ought nil "a") + (ought nil "a/b") + (ought nil "a/b/") + (ought t "~") + (when (version< "27.1" emacs-version) + (ought t "~/foo") + (ought nil "~foo") + (ought nil "~foo/")) + (ought t "~root") + (ought t "~root/") + (ought t "~root/file")) + (provide 'compat-tests) ;;; compat-tests.el ends here @@ -1,12 +1,12 @@ -;;; compat.el --- Compatibility Library -*- lexical-binding: t; -*- +;;; compat.el --- Emacs Lisp Compatibility Library -*- lexical-binding: t; -*- -;; Copyright (C) 2021 Free Software Foundation, Inc. +;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. ;; Author: Philip Kaludercic <philipk@posteo.net> -;; Maintainer: Philip Kaludercic <~pkal/public-inbox@lists.sr.ht> -;; Version: 28.1.0.0-rc -;; URL: https://git.sr.ht/~pkal/compat/ -;; Package-Requires: ((emacs "24.1") (nadvice "0.3")) +;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht> +;; Version: 28.1.2.0 +;; 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 @@ -39,145 +39,19 @@ ;;; Code: -(eval-when-compile (require 'compat-macs)) - -;;;; Core functionality - -;; The implementation is extracted here so that compatibility advice -;; can check if the right number of arguments are being handled. -(defun compat-func-arity (func) - "A reimplementation of `func-arity' for FUNC." - (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)))) - -(eval-and-compile - (defun compat-maxargs-/= (func n) - "Non-nil when FUNC doesn't accept at most N arguments." - (condition-case nil - (not (eq (cdr (compat-func-arity func)) n)) - (void-function t)))) - -;; Load the actual compatibility definitions: -(require 'compat-24.4) -(require 'compat-25.1) -(require 'compat-26.1) -(require 'compat-27.1) -(require 'compat-28.1) -(require 'compat-29.1) - -;;;; Etcetera - -;; To ensure that compat.el is loaded as soon as possible, a require -;; call is inserted directly into the autoload file: -;;;###autoload (require 'compat) - -;;;;; Update defaults - -;; This section updates default values that have been updated in -;; "future" versions of Emacs, and are relevant to users on older -;; versions of Emacs. -;; -;; To prevent these changes from taking effect, set -;; `compat-preserve-defaults' to t in your early-init.el on Emacs 27 or -;; before calling `package-initialize' before Emacs 27. - -(defvar compat-preserve-defaults nil) - -(unless compat-preserve-defaults - ;; Add NonGNU ELPA to the list of package archives - (defvar package-archives) - (with-eval-after-load 'package - (when (or (equal '(("gnu" . "https://elpa.gnu.org/packages/")) - package-archives) - (equal '(("gnu" . "http://elpa.gnu.org/packages/")) - package-archives)) - (push (cons "nongnu" - (format "http%s://elpa.nongnu.org/nongnu/" - (if (and (fboundp 'gnutls-available-p) - (gnutls-available-p)) - "s" ""))) - package-archives))) - - ;; Change the default IRC server from Freenode to Libera. - (defvar rcirc-server-alist) - (with-eval-after-load 'rcirc - (when (equal '(("chat.freenode.net" :channels ("#rcirc"))) - rcirc-server-alist) - (setq rcirc-server-alist - (if (and (fboundp 'gnutls-available-p) - (gnutls-available-p)) - ;; The #emacs channel is not added here (even though - ;; it was added in 28.1), since that is a separate - ;; feature that doesn't need to be added here. - '(("irc.libera.chat" :channels ("#rcirc") - :port 6697 :encryption tls)) - '(("irc.libera.chat" :channels ("#rcirc"))))))) - - (defvar erc-default-server) - (with-eval-after-load 'erc - (when (equal erc-default-server "irc.freenode.net") - (setq erc-default-server "irc.libera.chat")))) +(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 diff --git a/compat.texi b/compat.texi new file mode 100644 index 0000000..2335e99 --- /dev/null +++ b/compat.texi @@ -0,0 +1,1163 @@ +\input texinfo @c -*- texinfo -*- +@c %**start of header +@setfilename compat.info +@settitle "Compat" Manual +@documentencoding UTF-8 +@documentlanguage en +@c %**end of header + +@copying +Copyright @copyright{} 2022 Free Software Foundation, Inc. + +@quotation +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with the Front-Cover Texts being “A GNU Manual,” and +with the Back-Cover Texts as in (a) below. A copy of the license is +included in the section entitled “GNU Free Documentation License.” + +(a) The FSF’s Back-Cover Text is: “You have the freedom to copy and +modify this GNU manual.” + +@end quotation +@end copying + +@dircategory Emacs +@direntry +* Compat: (compat). Compatibility Library for Emacs Lisp. +@end direntry + +@finalout +@titlepage +@title "Compat" Manual +@subtitle For version 28.1.2.0 +@author Philip Kaludercic +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@contents + +@ifnottex +@node Top +@top "Compat" Manual + +This manual documents the usage of the "Compat" Emacs lisp library, +the forward-compatibility library for Emacs Lisp, corresponding to +version 28.1.2.0. + +@insertcopying +@end ifnottex + +@menu +* Introduction:: +* Support:: +* Development:: +* Function Index:: +* Variable Index:: + +@detailmenu +--- The Detailed Node Listing --- + +Introduction + +* Overview:: +* Usage:: +* Intentions:: + +Usage + +* Additional libraries:: + +Support + +* Emacs 24.4:: Compatibility support for Emacs 24.4 +* Emacs 24.5:: Compatibility support for Emacs 24.5 +* Emacs 25.1:: Compatibility support for Emacs 25.1 +* Emacs 26.1:: Compatibility support for Emacs 26.1 +* Emacs 27.1:: Compatibility support for Emacs 27.1 +* Emacs 28.1:: Compatibility support for Emacs 28.1 + +@end detailmenu +@end menu + +@node Introduction +@chapter Introduction + +@menu +* Overview:: +* Usage:: +* Intentions:: +@end menu + +@node Overview +@section Overview + +The objective of Compat is to provide "forwards compatibility" +library for Emacs Lisp. That is to say by using Compat, an Elisp +package does not have to make the decision to either use new and +useful functionality or support old versions of Emacs. + +Version 24.3 is chosen as the oldest version, because this is the +newest version on CentOS 7. It is intended to preserve compatibility +for at least as the Centos 7 reaches @uref{https://wiki.centos.org/About/Product, EOL}, 2024. + +If you are developing a package with Compat in mind, consider loading +`compat-help` (on your system, not in a package) to get relevant notes +inserted into the help buffers of functions that are implemented or +advised in Compat. + +Note that Compat provides a few prefixed function, ie. functions with +a @code{compat-} prefix. These are used to provide extended functionality +for commands that are already defined (@code{sort}, @code{assoc}, @code{seq}, @dots{}). +It might be possible to transform these into advised functions later +on, so that the modified functionality is accessible without a prefix. +Feedback on this point is appreciated. + +@node Usage +@section Usage + +The intended use-case for this library is for package developers to +add as a dependency in the header: + +@example +;; Package-Requires: ((emacs "24.3") (compat "28.1.2.0")) +@end example + + +and later on a + +@example +(require 'compat) +@end example + + +This will load all non-prefixed definitions (functions and macros with +a leading `compat-`). To load these, an additional + +@example +(require 'compat-XY) ; e.g. 26 +@end example + + +will be necessary, to load compatibility code for Emacs version XY@. + +It is recommended to subscribe to the @uref{https://lists.sr.ht/~pkal/compat-announce, compat-announce} mailing list to +be notified when new versions are released or relevant changes are +made. + +@menu +* Additional libraries:: +@end menu + +@node Additional libraries +@subsection Additional libraries + +These libraries are packages with Compat, but are disabled by default. +To use them you can use @code{M-x load-library}: + +@table @asis +@item compat-help +Add notes to @code{*Help*} buffer, if a compatibility +definition has something to warn you about. +@item compat-font-lock +Highlight functions that are implemented as +compatibility definitions. +@end table + +@node Intentions +@section Intentions + +The library intends to provide support back until Emacs 24.3. The +intended audience are package developers that are interested in using +newer developments, without having to break compatibility. + +Sadly, total backwards compatibility cannot be provided for technical +reasons. These might include: + +@itemize +@item +An existing function or macro was extended by some new functionality. To +support these cases, the function or macro would have to be advised. +As this is usually regarded as invasive and is shown to be a +significant overhead, even when the new feature is not used, this +approach is not used. + +As a compromise, prefixed functions and macros (starting with a +@code{compat-} prefix) can be provided. + +@item +New functionality was implemented in the core, and depends on +external libraries that cannot be reasonably duplicated in the scope +of a compatibility library. + +@item +New functionality depends on an entire new, non-trivial library. +Sometimes these are provided via ELPA (xref, project, @dots{}), but other +times it would be infeasible to duplicate an entire library within +Compat while also providing the necessary backwards compatibility. + +@item +It just wasn't added, and there is no good reason (though good +excuses might exist). If you happen to find such a function, +@ref{Development, , reporting} it would be much appreciated. + +Always begin by assuming that this might be the case, unless proven +otherwise. +@end itemize + +@node Support +@chapter Support + +This section goes into the features that Compat manages and doesn't +manage to provide for each Emacs version. + +@menu +* Emacs 24.4:: Compatibility support for Emacs 24.4 +* Emacs 24.5:: Compatibility support for Emacs 24.5 +* Emacs 25.1:: Compatibility support for Emacs 25.1 +* Emacs 26.1:: Compatibility support for Emacs 26.1 +* Emacs 27.1:: Compatibility support for Emacs 27.1 +* Emacs 28.1:: Compatibility support for Emacs 28.1 +@end menu + +@node Emacs 24.4 +@section Emacs 24.4 + +The following functions and macros implemented in 24.4, and are +provided by Compat by default: + +@defmac with-eval-after-load +See @ref{Hooks for Loading,Hooks for Loading,,elisp,}. +@end defmac + +@defun special-form-p +See @ref{Special Forms,Special Forms,,elisp,}. +@end defun + +@defun macrop +See @ref{Simple Macro,Simple Macro,,elisp,}. +@end defun + +@defun string-suffix-p +See @ref{Text Comparison,Text Comparison,,elisp,}. +@end defun + +@defun delete-consecutive-dups +Defined in @code{subr.el}. +@end defun + +@defun define-error +See @ref{Error Symbols,Error Symbols,,elisp,}. +@end defun + +@defun bool-vector-exclusive-or +See @ref{Bool-Vectors,Bool-Vectors,,elisp,}. +@end defun + +@defun bool-vector-union +See @ref{Bool-Vectors,Bool-Vectors,,elisp,}. +@end defun + +@defun bool-vector-intersection +See @ref{Bool-Vectors,Bool-Vectors,,elisp,}. +@end defun + +@defun bool-vector-not +See @ref{Bool-Vectors,Bool-Vectors,,elisp,}. +@end defun + +@defun bool-vector-subsetp +See @ref{Bool-Vectors,Bool-Vectors,,elisp,}. +@end defun + +@defun bool-vector-count-consecutive +See @ref{Bool-Vectors,Bool-Vectors,,elisp,}. +@end defun + +@defun bool-vector-count-population +See @ref{Bool-Vectors,Bool-Vectors,,elisp,}. +@end defun + +@defun completion-table-merge +See @ref{Basic Completion,Basic Completion,,elisp,}. +@end defun + +@defun completion-table-with-cache +See @ref{Programmed Completion,Programmed + Completion,,elisp,}. +@end defun + +@defun face-spec-set +See @ref{Defining Faces,Defining Faces,,elisp,}. +@end defun + +These functions are prefixed with @code{compat} prefix, and are only loaded +when @code{compat-24} is required: + +@defun compat-= +@end defun +@defun compat-< +@end defun +@defun compat-> +@end defun +@defun compat-<= +@end defun +@defun compat->= +See @ref{Comparison of Numbers,Comparison of Numbers,,elisp,}. + +Allows for more than two arguments to be compared. +@end defun + +@defun compat-split-string +See @ref{Creating Strings,Creating Strings,,elisp,}. + +Takes optional argument TRIM@. +@end defun + +Compat does not provide support for the following Lisp features +implemented in 24.4: + +@itemize +@item +Allowing the second optional argument to @code{eval} to specify a lexical +environment. +@item +The @code{define-alternatives} macro. +@item +Support for the @code{defalias-fset-function} symbol property. +@item +The @code{group-gid} and @code{groupd-read-gid} functions. +@item +The @code{pre-redisplay-function} hook. +@item +Allowing for @code{with-demoted-errors} to take a additional argument @code{format}. +@item +The @code{face-spec-set} function. +@item +The @code{add-face-text-property} function. +@item +No @code{tty-setup-hook} hook. +@item +The @code{get-pos-property} function. +@item +The @code{define-advice} macro. +@item +Support for generators. +@item +The @code{string-trim}, @code{string-trim-left} and @code{string-trim-right} +functions. These are instead provided as prefixed function as part +of @ref{Emacs 26.1} support. +@end itemize + +@node Emacs 24.5 +@section Emacs 24.5 + +No special support for 24.5 was deemed necessary. + +@node Emacs 25.1 +@section Emacs 25.1 + +The following functions and macros implemented in 25.1, and are +provided by Compat by default: + +@defun format-message +See @ref{Formatting Strings,Formatting Strings,,elisp,}. +@end defun + +@defun directory-name-p +See @ref{Directory Names,Directory Names,,elisp,}. +@end defun + +@defun string-greaterp +See @ref{Text Comparison,Text Comparison,,elisp,}. +@end defun + +@defmac with-file-modes +See @ref{Changing Files,Changing Files,,elisp,}. +@end defmac + +@defun alist-get +See @ref{Association Lists,Association Lists,,elisp,}. +@end defun + +@defmac if-let +Defined in @code{subr-x.el}. +@end defmac + +@defmac when-let +Defined in @code{subr-x.el}. +@end defmac + +@defmac thread-first +Defined in @code{subr-x.el}. +@end defmac + +@defmac thread-last +Defined in @code{subr-x.el}. +@end defmac + +@defun macroexpand-1 +See @ref{Expansion,Expansion,,elisp,}. +@end defun + +@defun directory-files-recursively +See @ref{Contents of Directories,Contents of + Directories,,elisp,}. +@end defun + +@defun bool-vector +See @ref{Bool-Vectors,Bool-Vectors,,elisp,}. +@end defun + +These functions are prefixed with @code{compat} prefix, and are only loaded +when @code{compat-25} is required: + +@defun compat-sort +See @ref{Sequence Functions,Sequence Functions,,elisp,}. + +Adds support for vectors to be sorted, next to just lists. +@end defun + +Compat does not provide support for the following Lisp features +implemented in 25.1: + +@itemize +@item +New @code{pcase} patterns. +@item +The hook @code{prefix-command-echo-keystrokes-functions} and +@code{prefix-command-preserve-state-hook}. +@item +The hook @code{pre-redisplay-functions}. +@item +The function @code{make-process}. +@item +Support for the variable @code{inhibit-message}. +@item +The @code{define-inline} functionality. +@item +The functions @code{string-collate-lessp} and @code{string-collate-equalp}. +@item +Support for @code{alist-get} as a generalised variable. +@item +The function @code{funcall-interactivly}. +@item +The function @code{buffer-substring-with-bidi-context}. +@item +The function @code{font-info}. +@item +The function @code{default-font-width}. +@item +The function @code{window-font-height} and @code{window-font-width}. +@item +The function @code{window-max-chars-per-line}. +@item +The function @code{set-binary-mode}. +@item +The functions @code{bufferpos-to-filepos} and @code{filepos-to-bufferpos}. +@end itemize + +Note that the changes in Emacs 25.2 and 25.3 are also included here, +for the sake of simplicity. + +@node Emacs 26.1 +@section Emacs 26.1 + +The following functions and macros implemented in 26.1, and are +provided by Compat by default: + +@defun func-arity +See @ref{What Is a Function,What Is a Function,,elisp,}. +@end defun + +@defun mapcan +See @ref{Mapping Functions,Mapping Functions,,elisp,}. +@end defun + +@defun cXXXr +@end defun +@defun cXXXXr +See @ref{List Elements,List Elements,,elisp,}. +@end defun + +@defvar gensym-counter +See @code{gensym}. +@end defvar + +@defun gensym +See @ref{Creating Symbols,Creating Symbols,,elisp,}. +@end defun + +@defun make-nearby-temp-file +See @ref{Unique File Names,Unique File Names,,elisp,}. +@end defun + +@defvar mounted-file-systems +Defined in @code{files.el}. +@end defvar + +@defun temporary-file-directory +See @ref{Unique File Names,Unique File Names,,elisp,}. +@end defun + +@defmac if-let* +Defined in @code{subr-x.el}. +@end defmac + +@defmac when-let* +Defined in @code{subr-x.el}. +@end defmac + +@defmac and-let* +Defined in @code{subr-x.el}. + +@strong{@strong{Please Note:}} The implementation provided by Compat does not +include a bug that was observed with Emacs 26 (see @uref{https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31840}). +@end defmac + +@defun file-local-name +See @ref{Magic File Names,Magic File Names,,elisp,}. +@end defun + +@defun file-name-quoted-p +See @ref{File Name Expansion,File Name Expansion,,elisp,}. +@end defun + +@defun file-name-quote +See @ref{File Name Expansion,File Name Expansion,,elisp,}. +@end defun + +@defun image-property +Defined in @code{image.el}. + +This function can also be used as a generalised variable. To use +this you need to explicitly require @code{compat-26}. +@end defun + +@defun file-attribute-type +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-link-number +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-user-id +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-group-id +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-access-time +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-modification-time +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-status-change-time +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-size +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-modes +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-inode-number +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-device-number +See @ref{File Attributes,File Attributes,,elisp,}. +@end defun + +@defun file-attribute-collect +Defined in @code{files.el}. +@end defun + +These functions are prefixed with @code{compat} prefix, and are only loaded +when @code{compat-26} is required: + +@defun compat-assoc +See @ref{Association Lists,Association Lists,,elisp,}. + +Handle the optional argument TESTFN@. +@end defun + +@defun compat-line-number-at-pos +See @ref{Text Lines,Text Lines,,elisp,}. + +Handle the optional argument ABSOLUTE@. +@end defun + +@defun compat-alist-get +See @ref{Association Lists,Association Lists,,elisp,}. + +Handle the optional argument TESTFN@. Can also be used as a +generalised variable. +@end defun + +@defun compat-string-trim-left +See @ref{Creating Strings,Creating Strings,,elisp,}. + +Handles the optional argument REGEXP@. +@end defun + +@defun compat-string-trim-right +See @ref{Creating Strings,Creating Strings,,elisp,}. + +Handles the optional argument REGEXP@. +@end defun + +@defun compat-string-trim +See @ref{Creating Strings,Creating Strings,,elisp,}. + +Handles the optional arguments TRIM-LEFT and TRIM-RIGHT@. +@end defun + +Compat does not provide support for the following Lisp features +implemented in 26.1: + +@itemize +@item +The function @code{secure-hash-algorithms}. +@item +The function @code{gnutls-avalaible-p}. +@item +Support for records and record functions. +@item +The function @code{mapbacktrace}. +@item +The function @code{file-name-case-insensitive-p}. +@item +The file-attributes constructors. +@item +The function @code{read-multiple-choice}. +@item +The additional elements of @code{parse-partial-sexp}. +@item +The function @code{add-variable-watcher}. +@item +The function @code{undo-amalgamate-change-group}. +@item +The function @code{char-from-name} +@item +Signalling errors when @code{length} or @code{member} deal with list cycles. +@item +The function @code{frame-list-z-order}. +@item +The function @code{frame-restack}. +@item +Support for side windows and atomic windows. +@item +All changes related to @code{display-buffer}. +@item +The function @code{window-swap-states}. +@end itemize + +Note that the changes in Emacs 26.2 and 26.3 are also included here, +for the sake of simplicity. + +@node Emacs 27.1 +@section Emacs 27.1 + +The following functions and macros implemented in 27.1, and are +provided by Compat by default: + +@defun proper-list-p +See @ref{List-related Predicates,List-related Predicates,,elisp,}. +@end defun + +@defun string-distance +See @ref{Text Comparison,Text Comparison,,elisp,}. +@end defun + +@defun json-serialize +See @ref{Parsing JSON,Parsing JSON,,elisp,}. +@end defun + +@defun json-insert +See @ref{Parsing JSON,Parsing JSON,,elisp,}. +@end defun + +@defun json-parse-string +See @ref{Parsing JSON,Parsing JSON,,elisp,}. +@end defun + +@defun json-parse-buffer +See @ref{Parsing JSON,Parsing JSON,,elisp,}. +@end defun + +@defmac ignore-error +See @ref{Handling Errors,Handling Errors,,elisp,}. +@end defmac + +@defmac dolist-with-progress-reporter +See @ref{Progress,Progress,,elisp,}. +@end defmac + +@defun flatten-tree +See @ref{Building Lists,Building Lists,,elisp,}. +@end defun + +@defun xor +See @ref{Combining Conditions,Combining Conditions,,elisp,}. +@end defun + +@defvar regexp-unmatchable +Defined in @code{subr.el}. +@end defvar + +@defun decoded-time-second +Defined in @code{simple.el}. +@end defun + +@defun decoded-time-minute +Defined in @code{simple.el}. +@end defun + +@defun decoded-time-hour +Defined in @code{simple.el}. +@end defun + +@defun decoded-time-day +Defined in @code{simple.el}. +@end defun + +@defun decoded-time-month +Defined in @code{simple.el}. +@end defun + +@defun decoded-time-year +Defined in @code{simple.el}. +@end defun + +@defun decoded-time-weekday +Defined in @code{simple.el}. +@end defun + +@defun decoded-time-dst +Defined in @code{simple.el}. +@end defun + +@defun decoded-time-zone +Defined in @code{simple.el}. +@end defun + +@defun package-get-version +Defined in @code{package.el}. +@end defun + +@defun time-equal-p +See @ref{Time Calculations,Time Calculations,,elisp,}. +@end defun + +@defun date-days-in-month +See @ref{Time Calculations,Time Calculations,,elisp,}. +@end defun + +@defun exec-path +See @ref{Subprocess Creation,Subprocess Creation,,elisp,}. + +This function requires the @code{time-date} feature to be loaded. +@end defun + +These functions are prefixed with @code{compat} prefix, and are only loaded +when @code{compat-27} is required: + +@defun compat-recenter +See @ref{Textual Scrolling,Textual Scrolling,,elisp,}. + +Adds the optional argument REDISPLAY@. +@end defun + +@defun compat-lookup-key +See @ref{Low-Level Key Binding,Low-Level Key Binding,,elisp,}. + +Allows KEYMAP to be a list of keymaps. +@end defun + +@defmac compat-setq-local +See @ref{Creating Buffer-Local,Creating Buffer-Local,,elisp,}. + +Allow for more than one variable to be set. +@end defmac + +@defun compat-regexp-opt +See @ref{Regexp Functions,Regexp Functions,,elisp,}. + +Handle an empty list of strings. +@end defun + +@defun compat-file-size-human-readable +Defined in @code{files.el}. + +Handle the optional third (SPACE) and forth (UNIT) arguments. +@end defun + +@defun compat-assoc-delete-all +See @ref{Association Lists,Association Lists,,elisp,}. + +Handle the optional third (TESTFN) argument. +@end defun + +@defun compat-executable-find +@ref{Locating Files,Locating Files,,elisp,}. + +Handle the optional second (REMOTE) argument. +@end defun + +@defun compat-dired-get-marked-files +Defined in @code{dired.el} + +Handles the optional fifth (ERROR) argument. +@end defun + +Compat does not provide support for the following Lisp features +implemented in 27.1: + +@itemize +@item +Bigint support. +@item +The function @code{time-convert}. +@item +All @code{iso8601-*} functions. +@item +The macro @code{benchmark-progn}. +@item +The function @code{read-char-from-minibuffer}. +@item +The minor mode @code{reveal-mode}. +@item +The macro @code{with-suppressed-warnings}. +@item +Support for @code{condition-case} to handle t. +@item +The functions @code{major-mode-suspend} and @code{major-mode-restore}. +@item +The function @code{provided-mode-derived-p}. +@item +The function @code{file-system-info}. +@item +The more consistent treatment of NaN values. +@item +The function @code{ring-resize}. +@item +The function @code{group-name}. +@item +Additional @code{format-spec} modifiers. +@item +Support for additional body forms for +@code{define-globalized-minor-mode}. +@item +The macro @code{with-connection-local-variables} and related +functionality. +@end itemize + +Note that the changes in Emacs 27.2 are also included here, for the +sake of simplicity. + +@node Emacs 28.1 +@section Emacs 28.1 + +The following functions and macros implemented in 28.1, and are +provided by Compat by default: + +@defun string-search +See @ref{Text Comparison,Text Comparison,,elisp,}. +@end defun + +@defun length= +See @ref{Sequence Functions,Sequence Functions,,elisp,}. +@end defun + +@defun length< +See @ref{Sequence Functions,Sequence Functions,,elisp,}. +@end defun + +@defun length> +See @ref{Sequence Functions,Sequence Functions,,elisp,}. +@end defun + +@defun file-name-concat +See @ref{Directory Names,Directory Names,,elisp,}. +@end defun + +@defun garbage-collect-maybe +Defined in @code{alloc.c}. +@end defun + +@defun string-replace +See @ref{Search and Replace,Search and Replace,,elisp,}. +@end defun + +@defun always +@ref{Calling Functions,Calling Functions,,elisp,}. +@end defun + +@defun insert-into-buffer +See @ref{Insertion,Insertion,,elisp,}. +@end defun + +@defun replace-regexp-in-region +See @ref{Search and Replace,Search and Replace,,elisp,}. +@end defun + +@defun replace-string-in-region +See @ref{Search and Replace,Search and Replace,,elisp,}. +@end defun + +@defun buffer-local-boundp +See @ref{Creating Buffer-Local,Creating Buffer-Local,,elisp,}. +@end defun + +@defun with-existing-directory +See @ref{Testing Accessibility,Testing Accessibility,,elisp,}. +@end defun + +@defmac dlet +See @ref{Local Variables,Local Variables,,elisp,}. +@end defmac + +@defun ensure-list +See @ref{Building Lists,Building Lists,,elisp,}. +@end defun + +@defun string-clean-whitespace +See @ref{Creating Strings,Creating Strings,,elisp,}. +@end defun + +@defun string-fill +See @ref{Creating Strings,Creating Strings,,elisp,}. +@end defun + +@defun string-lines +See @ref{Creating Strings,Creating Strings,,elisp,}. +@end defun + +@defun string-pad +See @ref{Creating Strings,Creating Strings,,elisp,}. +@end defun + +@defun string-chop-newline +See @ref{Creating Strings,Creating Strings,,elisp,}. +@end defun + +@defmac named-let +See @ref{Local Variables,Local Variables,,elisp,}. +@end defmac + +@defun file-name-with-extension +See @ref{File Name Components,File Name + Components,,elisp,}. +@end defun + +@defun directory-empty-p +See @ref{Contents of Directories,Contents of Directories,,elisp,}. +@end defun + +@defun format-prompt +See @ref{Text from Minibuffer,Text from Minibuffer,,elisp,}. +@end defun + +@defun thing-at-mouse +Defined in @code{thingatpt.el}. +@end defun + +@defun macroexp-file-name +Defined in @code{macroexp}. +@end defun + +@defmac with-environment-variables +See @ref{System Environment,System + Environment,,elisp,}. +@end defmac + +@defun button-buttonize +Defined in @code{button.el}. +@end defun + +@defun make-directory-autoloads +See @ref{Autoload,Autoload,,elisp,}. +@end defun + +@defun color-values-from-color-spec +Defined in @code{xfaces.c}. +@end defun + +@defun file-modes-number-to-symbolic +See @ref{Changing Files,Changing + Files,,elisp,}. +@end defun + +@defun file-backup-file-names +See @ref{Backup Names,Backup Names,,elisp,}. +@end defun + +@defun make-lock-file-name +Defined in @code{files.el}. +@end defun + +@defun null-device +Defined in @code{files.el}. +@end defun + +@defun decoded-time-period +Defined in @code{time-data.el}. +@end defun + +@defun subr-primitive-p +Defined in @code{subr.el}. +@end defun + +@defun file-name-absolute-p +See @ref{Absolute and Relative File Names,Relative File Names,,elisp,}. +@end defun + +These functions are prefixed with @code{compat} prefix, and are only loaded +when @code{compat-28} is required: + +@defun compat-unlock-buffer +See @ref{File Locks,File Locks,,elisp,}. + +Handle @code{file-error} conditions. +@end defun + +@defun compat-string-width +See @ref{Size of Displayed Text,Size of Displayed Text,,elisp,}. + +Handle optional arguments FROM and TO@. +@end defun + +@defun compat-json-serialize +See @ref{Parsing JSON,Parsing JSON,,elisp,}. + +Handle primitive, top-level JSON values. +@end defun + +@defun compat-json-insert +See @ref{Parsing JSON,Parsing JSON,,elisp,}. + +Handle primitive, top-level JSON values. +@end defun + +@defun compat-json-parse-string +See @ref{Parsing JSON,Parsing JSON,,elisp,}. + +Handle primitive, top-level JSON values. +@end defun + +@defun compat-json-parse-buffer +See @ref{Parsing JSON,Parsing JSON,,elisp,}. + +Handle primitive, top-level JSON values. +@end defun + +@defun compat-count-windows +Defined in @code{window.el}. + +Handle optional argument ALL-FRAMES@. +@end defun + +Compat does not provide support for the following Lisp features +implemented in 28.1: + +@itemize +@item +Support for @code{interactive} or @code{declare} to list applicable modes. +@item +Support for @code{:interactive} argument to @code{define-minor-mode} and +@code{define-derived-mode}. +@item +Support for @code{:predicate} argument to @code{define-globalized-minor-mode}. +@item +"Success handler" for @code{condition-case}. +@item +The function @code{benchmark-call}. +@item +Support for the @code{natnum} defcustom type. +@item +The function @code{macroexp-compiling-p}. +@item +The function @code{macroexp-warn-and-return}. +@item +Additional Edebug keywords. +@item +Shorthand support. +@item +The function @code{custom-add-choice}. +@item +The function @code{decoded-time-period}. +@item +The function @code{dom-print}. +@item +The function @code{dom-remove-attribute}. +@item +The function @code{dns-query-asynchronous}. +@item +The function @code{get-locale-names}. +@item +The function @code{json-avaliable-p}. +@item +The function @code{mail-header-parse-addresses-lax}. +@item +The function @code{mail-header-parse-address-lax}. +@item +The function @code{make-separator-line}. +@item +The function @code{num-processors}. +@item +The function @code{object-intervals}. +@item +The function @code{process-lines-ignore-status}. +@item +The function @code{require-theme}. +@item +The function @code{syntax-class-to-char}. +@item +The function @code{null-device} and @code{path-separator}. +@end itemize + +@node Development +@chapter Development + +Compat is developed on @uref{https://sr.ht/~pkal/compat, SourceHut}. A restricted @uref{https://github.com/phikal/compat.el, GitHub mirror} is also +maintained. + +Patches and comments can be sent to the @uref{https://lists.sr.ht/~pkal/compat-devel, development mailing list} +(@email{~pkal/compat-devel@@lists.sr.ht, ~pkal/compat-devel@@lists.sr.ht}). Bug reports are best sent to the +@uref{https://todo.sr.ht/~pkal/compat, issue tracker} (@email{~pkal/compat@@todo.sr.ht, ~pkal/compat@@todo.sr.ht}). The GitHub mirror can also +be used to submit patches. These may include issues in the +compatibility code, missing definitions or performance issues. + +Please note that as a GNU ELPA package, Compat requires contributors +to have signed the @uref{https://www.gnu.org/software/emacs/manual/html_node/emacs/Copyright-Assignment.html, FSF copyright assignment}, before any non-trivial +contribution (roughly 15 lines of code) can be applied. + +@node Function Index +@appendix Function Index + +@printindex fn + +@node Variable Index +@appendix Variable Index + +@printindex vr + +@bye + +@c Local Variables: +@c mode: texinfo +@c TeX-master: t +@c End: |