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

update of packages

Browse Source
This commit is contained in:
Daniel Weschke
2023-11-04 19:26:41 +01:00
parent e162a12b58
commit 3b54a3236d
726 changed files with 297673 additions and 34585 deletions
Download Patch File Download Diff File Expand all files Collapse all files

643
lisp/compat/compat-26.el
View File

@@ -1,11 +1,6 @@
;;; compat-26.el --- Compatibility Layer for Emacs 26.1 -*- lexical-binding: t; -*-
;;; compat-26.el --- Functionality added in 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
;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -22,337 +17,284 @@
;;; 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'
;; Functionality added in Emacs 26.1, needed by older Emacs versions.
;;; Code:
(require 'compat-macs "compat-macs.el")
(eval-when-compile (load "compat-macs.el" nil t t))
(compat-require compat-25 "25.1")
(compat-declare-version "26.1")
;;;; Defined in eval.c
(compat-defun func-arity (func)
"Return minimum and maximum number of args allowed for FUNC.
FUNC must be a function of some kind.
The returned value is a cons cell (MIN . MAX). MIN is the minimum number
of args. MAX is the maximum number, or the symbol `many', for a
function with `&rest' args, or `unevalled' for a special form."
:realname compat--func-arity
(cond
((or (null func) (and (symbolp func) (not (fboundp func))))
(signal 'void-function func))
((and (symbolp func) (not (null func)))
(compat--func-arity (symbol-function func)))
((eq (car-safe func) 'macro)
(compat--func-arity (cdr func)))
((subrp func)
(subr-arity func))
((memq (car-safe func) '(closure lambda))
;; See lambda_arity from eval.c
(when (eq (car func) 'closure)
(setq func (cdr func)))
(let ((syms-left (if (consp func)
(car func)
(signal 'invalid-function func)))
(min-args 0) (max-args 0) optional)
(catch 'many
(dolist (next syms-left)
(cond
((not (symbolp next))
(signal 'invalid-function func))
((eq next '&rest)
(throw 'many (cons min-args 'many)))
((eq next '&optional)
(setq optional t))
(t (unless optional
(setq min-args (1+ min-args)))
(setq max-args (1+ max-args)))))
(cons min-args max-args))))
((and (byte-code-function-p func) (numberp (aref func 0)))
;; See get_byte_code_arity from bytecode.c
(let ((at (aref func 0)))
(cons (logand at 127)
(if (= (logand at 128) 0)
(ash at -8)
'many))))
((and (byte-code-function-p func) (numberp (aref func 0)))
;; See get_byte_code_arity from bytecode.c
(let ((at (aref func 0)))
(cons (logand at 127)
(if (= (logand at 128) 0)
(ash at -8)
'many))))
((and (byte-code-function-p func) (listp (aref func 0)))
;; Based on `byte-compile-make-args-desc', this is required for
;; old versions of Emacs that don't use a integer for the argument
;; list description, per e2abe5a13dffb08d6371b6a611bc39c3a9ac2bc6.
(let ((arglist (aref func 0)) (mandatory 0) nonrest)
(while (and arglist (not (memq (car arglist) '(&optional &rest))))
(setq mandatory (1+ mandatory))
(setq arglist (cdr arglist)))
(setq nonrest mandatory)
(when (eq (car arglist) '&optional)
(setq arglist (cdr arglist))
(while (and arglist (not (eq (car arglist) '&rest)))
(setq nonrest (1+ nonrest))
(setq arglist (cdr arglist))))
(cons mandatory (if arglist 'many nonrest))))
((autoloadp func)
(autoload-do-load func)
(compat--func-arity func))
((signal 'invalid-function func))))
(compat-version "26.1")
;;;; 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 buffer-hash (&optional buffer-or-name) ;; <compat-tests:buffer-hash>
"Return a hash of the contents of BUFFER-OR-NAME.
This hash is performed on the raw internal format of the buffer,
disregarding any coding systems. If nil, use the current buffer.
(compat-defun mapcan (func sequence)
This function is useful for comparing two buffers running in the same
Emacs, but is not guaranteed to return the same hash between different
Emacs versions. It should be somewhat more efficient on larger
buffers than `secure-hash' is, and should not allocate more memory.
It should not be used for anything security-related. See
`secure-hash' for these applications."
(with-current-buffer (or buffer-or-name (current-buffer))
(save-restriction
(widen)
(sha1 (current-buffer) (point-min) (point-max)))))
(compat-defun mapcan (func sequence) ;; <compat-tests:mapcan>
"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
(compat-defun line-number-at-pos (&optional position absolute) ;; <compat-tests:line-number-at-pos>
"Handle optional argument ABSOLUTE."
:extended t
(if absolute
(save-restriction
(widen)
(line-number-at-pos position))
(line-number-at-pos position)))
;;;; Defined in simple.el
(compat-defun region-bounds () ;; <compat-tests:region-bounds>
"Return the boundaries of the region.
Value is a list of one or more cons cells of the form (START . END).
It will have more than one cons cell when the region is non-contiguous,
see `region-noncontiguous-p' and `extract-rectangle-bounds'."
(if (eval-when-compile (< emacs-major-version 25))
;; FIXME: The `region-extract-function' of Emacs 24 has no support for the
;; bounds argument.
(list (cons (region-beginning) (region-end)))
(funcall region-extract-function 'bounds)))
;;;; 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)))
(compat-defun provided-mode-derived-p (mode &rest modes) ;; <compat-tests:provided-derived-mode-p>
"Non-nil if MODE is derived from one of MODES.
Uses the `derived-mode-parent' property of the symbol to trace backwards.
If you just want to check `major-mode', use `derived-mode-p'."
;; If MODE is an alias, then look up the real mode function first.
(let ((alias (symbol-function mode)))
(when (and alias (symbolp alias))
(setq mode alias)))
(while
(and
(not (memq mode modes))
(let* ((parent (get mode 'derived-mode-parent))
(parentfn (symbol-function parent)))
(setq mode (if (and parentfn (symbolp parentfn)) parentfn parent)))))
mode)
(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 assoc (key alist &optional testfn) ;; <compat-tests:assoc>
"Handle the optional TESTFN."
:extended t
(cond
((or (eq testfn #'eq)
(and (not testfn) (or (symbolp key) (integerp key)))) ;; eq_comparable_value
(assq key alist))
((or (eq testfn #'equal) (not testfn))
(assoc key alist))
(t
(catch 'found
(dolist (ent alist)
(when (funcall testfn (car ent) key)
(throw 'found ent)))))))
(compat-defun string-trim-left (string &optional regexp)
"Trim STRING of leading string matching REGEXP.
(compat-defun alist-get (key alist &optional default remove testfn) ;; <compat-tests:alist-get>
"Handle optional argument TESTFN."
:extended "25.1"
(ignore remove)
(let ((x (if (not testfn)
(assq key alist)
(compat--assoc key alist testfn))))
(if x (cdr x) default)))
REGEXP defaults to \"[ \\t\\n\\r]+\"."
:realname compat--string-trim-left
:prefix t
(compat-guard t ;; <compat-tests:alist-get-gv>
(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 `(compat--assoc ,k ,getter ,testfn)
(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))))))))))
(unless (get 'alist-get 'gv-expander)
(put 'alist-get 'gv-expander (get 'compat--alist-get 'gv-expander))))
(compat-defun string-trim-left (string &optional regexp) ;; <compat-tests:string-trim-left>
"Handle optional argument REGEXP."
:extended 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
(compat-defun string-trim-right (string &optional regexp) ;; <compat-tests:string-trim-right>
"Handle optional argument REGEXP."
:extended 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-defun string-trim (string &optional trim-left trim-right) ;; <compat-tests:string-trim>
"Handle optional arguments TRIM-LEFT and TRIM-RIGHT."
:extended t
(compat--string-trim-left
(compat--string-trim-right
string
trim-right)
trim-left))
(compat-defun caaar (x)
(compat-defun caaar (x) ;; <compat-tests:cXXXr>
"Return the `car' of the `car' of the `car' of X."
(declare (pure t))
(car (car (car x))))
(compat-defun caadr (x)
(compat-defun caadr (x) ;; <compat-tests:cXXXr>
"Return the `car' of the `car' of the `cdr' of X."
(declare (pure t))
(car (car (cdr x))))
(compat-defun cadar (x)
(compat-defun cadar (x) ;; <compat-tests:cXXXr>
"Return the `car' of the `cdr' of the `car' of X."
(declare (pure t))
(car (cdr (car x))))
(compat-defun caddr (x)
(compat-defun caddr (x) ;; <compat-tests:cXXXr>
"Return the `car' of the `cdr' of the `cdr' of X."
(declare (pure t))
(car (cdr (cdr x))))
(compat-defun cdaar (x)
(compat-defun cdaar (x) ;; <compat-tests:cXXXr>
"Return the `cdr' of the `car' of the `car' of X."
(declare (pure t))
(cdr (car (car x))))
(compat-defun cdadr (x)
(compat-defun cdadr (x) ;; <compat-tests:cXXXr>
"Return the `cdr' of the `car' of the `cdr' of X."
(declare (pure t))
(cdr (car (cdr x))))
(compat-defun cddar (x)
(compat-defun cddar (x) ;; <compat-tests:cXXXr>
"Return the `cdr' of the `cdr' of the `car' of X."
(declare (pure t))
(cdr (cdr (car x))))
(compat-defun cdddr (x)
(compat-defun cdddr (x) ;; <compat-tests:cXXXr>
"Return the `cdr' of the `cdr' of the `cdr' of X."
(declare (pure t))
(cdr (cdr (cdr x))))
(compat-defun caaaar (x)
(compat-defun caaaar (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun caaadr (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun caadar (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun caaddr (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cadaar (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cadadr (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun caddar (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cadddr (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cdaaar (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cdaadr (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cdadar (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cdaddr (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cddaar (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cddadr (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cdddar (x) ;; <compat-tests:cXXXXr>
"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)
(compat-defun cddddr (x) ;; <compat-tests:cXXXXr>
"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
(compat-defvar gensym-counter 0 ;; <compat-tests:gensym>
"Number used to construct the name of the next symbol created by `gensym'.")
(compat-defun gensym (&optional prefix)
(compat-defun gensym (&optional prefix) ;; <compat-tests:gensym>
"Return a new uninterned symbol.
The name is made by appending `gensym-counter' to PREFIX.
PREFIX is a string, and defaults to \"g\"."
@@ -361,27 +303,52 @@ PREFIX is a string, and defaults to \"g\"."
(1+ gensym-counter)))))
(make-symbol (format "%s%d" (or prefix "g") num))))
(compat-defmacro if-let* (varlist then &rest else) ;; <compat-tests:if-let*>
"Bind variables according to VARLIST and evaluate THEN or ELSE.
This is like `if-let' but doesn't handle a VARLIST of the form
\(SYMBOL SOMETHING) specially."
(declare (indent 2)
(debug ((&rest [&or symbolp (symbolp form) (form)])
body)))
(let ((empty (make-symbol "s"))
(last t) list)
(dolist (var varlist)
(push `(,(if (cdr var) (car var) empty)
(and ,last ,(if (cdr var) (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) ;; <compat-tests:when-let*>
"Bind variables according to VARLIST and conditionally evaluate BODY.
This is like `when-let' but doesn't handle a VARLIST of the form
\(SYMBOL SOMETHING) specially."
(declare (indent 1) (debug if-let*))
(list 'if-let* varlist (macroexp-progn body)))
(compat-defmacro and-let* (varlist &rest body) ;; <compat-tests:and-let*>
"Bind variables according to VARLIST and conditionally evaluate BODY.
Like `when-let*', except if BODY is empty and all the bindings
are non-nil, then the result is non-nil."
(declare (indent 1)
(debug ((&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 ,(if (cdr var) (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 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
(compat-defvar mounted-file-systems ;; <compat-tests:mounted-file-systems>
(eval-when-compile
(if (memq system-type '(windows-nt cygwin))
"^//[^/]+/"
@@ -389,35 +356,16 @@ same meaning as in `make-temp-file'."
"^" (regexp-opt '("/afs/" "/media/" "/mnt" "/net/" "/tmp_mnt/")))))
"File systems that ought to be mounted.")
(compat-defun file-local-name (file)
(compat-defun file-local-name (file) ;; <compat-tests:file-local-name>
"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 ()
(compat-defun temporary-file-directory () ;; <compat-tests: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
@@ -426,87 +374,107 @@ 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."
;; NOTE: The handler may fail with an error, since the
;; `temporary-file-directory' handler was introduced in Emacs 26.
(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))))
(or (and handler (ignore-errors (funcall handler 'temporary-file-directory)))
(if-let ((remote (file-remote-p default-directory)))
(concat remote "/tmp/") ;; FIXME: Guess /tmp on remote host
(if (string-match mounted-file-systems default-directory)
default-directory
temporary-file-directory)))))
;;* UNTESTED
(compat-defun file-attribute-type (attributes)
(compat-defun make-temp-file (prefix &optional dir-flag suffix text) ;; <compat-tests:make-temp-file>
"Handle optional argument TEXT."
:extended t
(let ((file (make-temp-file prefix dir-flag suffix)))
(when text
(with-temp-buffer
(insert text)
(write-region (point-min) (point-max) file)))
file))
(compat-defun make-nearby-temp-file (prefix &optional dir-flag suffix) ;; <compat-tests:make-nearby-temp-file>
"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'."
;; NOTE: The handler may fail with an error, since the
;; `make-nearby-temp-file' handler was introduced in Emacs 26.
(let ((handler (and (not (file-name-absolute-p default-directory))
(find-file-name-handler
default-directory 'make-nearby-temp-file))))
(or (and handler (ignore-errors (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-defun file-attribute-type (attributes) ;; <compat-tests:file-attribute-getters>
"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)
(compat-defun file-attribute-link-number (attributes) ;; <compat-tests:file-attribute-getters>
"Return the number of links in ATTRIBUTES returned by `file-attributes'."
(nth 1 attributes))
;;* UNTESTED
(compat-defun file-attribute-user-id (attributes)
(compat-defun file-attribute-user-id (attributes) ;; <compat-tests:file-attribute-getters>
"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)
(compat-defun file-attribute-group-id (attributes) ;; <compat-tests:file-attribute-getters>
"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)
(compat-defun file-attribute-access-time (attributes) ;; <compat-tests:file-attribute-getters>
"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)
(compat-defun file-attribute-modification-time (attributes) ;; <compat-tests:file-attribute-getters>
"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)
(compat-defun file-attribute-status-change-time (attributes) ;; <compat-tests:file-attribute-getters>
"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)
(compat-defun file-attribute-size (attributes) ;; <compat-tests:file-attribute-getters>
"The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'."
(nth 7 attributes))
;;* UNTESTED
(compat-defun file-attribute-modes (attributes)
(compat-defun file-attribute-modes (attributes) ;; <compat-tests:file-attribute-getters>
"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)
(compat-defun file-attribute-inode-number (attributes) ;; <compat-tests:file-attribute-getters>
"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)
(compat-defun file-attribute-device-number (attributes) ;; <compat-tests:file-attribute-getters>
"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)
(compat-defun file-attribute-collect (attributes &rest attr-names) ;; <compat-tests:file-attribute-collect>
"Return a sublist of ATTRIBUTES returned by `file-attributes'.
ATTR-NAMES are symbols with the selected attribute names.
@@ -534,105 +502,28 @@ inode-number and device-number."
(error "Wrong attribute name '%S'" attr))))
(nreverse result)))
;;;; Defined in subr-x.el
;;;; Defined in mouse.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)))))))
(compat-defvar mouse-select-region-move-to-beginning nil ;; <compat-tests:thing-at-mouse>
"Effect of selecting a region extending backward from double click.
Nil means keep point at the position clicked (region end);
non-nil means move point to beginning of region.")
;;;; Defined in image.el
;;* UNTESTED
(compat-defun image-property (image property)
(compat-defun image-property (image property) ;; <compat-tests: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."
:feature image
(plist-get (cdr image) property))
;;* UNTESTED
(unless (get 'image-property 'gv-expander)
(gv-define-setter image-property (image property value)
(let ((image* (make-symbol "image"))
(property* (make-symbol "property"))
(value* (make-symbol "value")))
`(let ((,image* ,image)
(,property* ,property)
(,value* ,value))
(if
(null ,value*)
(while
(cdr ,image*)
(if
(eq
(cadr ,image*)
,property*)
(setcdr ,image*
(cdddr ,image*))
(setq ,image*
(cddr ,image*))))
(setcdr ,image*
(plist-put
(cdr ,image*)
,property* ,value*)))))))
;;;; Defined in rmc.el
;;*UNTESTED
(compat-defun read-multiple-choice
(prompt choices &optional _help-string _show-help long-form)
(compat-defun read-multiple-choice (prompt choices) ;; <compat-tests:read-multiple-choice>
"Ask user to select an entry from CHOICES, promting with PROMPT.
This function allows to ask the user a multiple-choice question.
@@ -641,35 +532,23 @@ KEY is a character the user should type to select the entry.
NAME is a short name for the entry to be displayed while prompting
\(if there's no room, it might be shortened).
If LONG-FORM, do a `completing-read' over the NAME elements in
CHOICES instead."
:note "This is a partial implementation of `read-multiple-choice', that
NOTE: This is a partial implementation of `read-multiple-choice', that
among other things doesn't offer any help and ignores the
optional DESCRIPTION field."
(if long-form
(let ((options (mapconcat #'cadr choices "/"))
choice)
(setq prompt (concat prompt " (" options "): "))
(setq choice (completing-read prompt (mapcar #'cadr choices) nil t))
(catch 'found
(dolist (option choices)
(when (string= choice (cadr option))
(throw 'found option)))
(error "Invalid choice")))
(let ((options
(mapconcat
(lambda (opt)
(format
"[%s] %s"
(key-description (string (car opt)))
(cadr opt)))
choices " "))
choice)
(setq prompt (concat prompt " (" options "): "))
(while (not (setq choice (assq (read-char prompt) choices)))
(message "Invalid choice")
(sit-for 1))
choice)))
(let ((options
(mapconcat
(lambda (opt)
(format
"[%s] %s"
(key-description (string (car opt)))
(cadr opt)))
choices " "))
choice)
(setq prompt (concat prompt " (" options "): "))
(while (not (setq choice (assq (read-event prompt) choices)))
(message "Invalid choice")
(sit-for 1))
choice))
(compat--inhibit-prefixed (provide 'compat-26))
(provide 'compat-26)
;;; compat-26.el ends here