compat-26.el (18266B)
1 ;;; compat-26.el --- Compatibility Layer for Emacs 26.1 -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2021-2023 Free Software Foundation, Inc. 4 5 ;; This program is free software; you can redistribute it and/or modify 6 ;; it under the terms of the GNU General Public License as published by 7 ;; the Free Software Foundation, either version 3 of the License, or 8 ;; (at your option) any later version. 9 10 ;; This program is distributed in the hope that it will be useful, 11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 ;; GNU General Public License for more details. 14 15 ;; You should have received a copy of the GNU General Public License 16 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 17 18 ;;; Commentary: 19 20 ;; Find here the functionality added in Emacs 26.1, needed by older 21 ;; versions. 22 23 ;;; Code: 24 25 (eval-when-compile (load "compat-macs.el" nil t t)) 26 (compat-declare-version "26.1") 27 28 ;;;; Defined in fns.c 29 30 (compat-defun assoc (key alist &optional testfn) ;; <OK> 31 "Handle the optional TESTFN." 32 :explicit t 33 (if testfn 34 (catch 'found 35 (dolist (ent alist) 36 (when (funcall testfn (car ent) key) 37 (throw 'found ent)))) 38 (assoc key alist))) 39 40 (compat-defun mapcan (func sequence) ;; <OK> 41 "Apply FUNC to each element of SEQUENCE. 42 Concatenate the results by altering them (using `nconc'). 43 SEQUENCE may be a list, a vector, a boolean vector, or a string." 44 (apply #'nconc (mapcar func sequence))) 45 46 (compat-defun line-number-at-pos (&optional position absolute) ;; <OK> 47 "Handle optional argument ABSOLUTE." 48 :explicit t 49 (if absolute 50 (save-restriction 51 (widen) 52 (line-number-at-pos position)) 53 (line-number-at-pos position))) 54 55 ;;;; Defined in subr.el 56 57 (compat-defun alist-get (key alist &optional default remove testfn) ;; <OK> 58 "Handle optional argument TESTFN." 59 :explicit t 60 (if testfn 61 (let (entry) 62 (cond 63 ((eq testfn 'eq) 64 (setq entry (assq key alist))) 65 ((eq testfn 'equal) 66 (setq entry (assoc key alist))) 67 ((catch 'found 68 (dolist (ent alist) 69 (when (and (consp ent) (funcall testfn (car ent) key)) 70 (throw 'found (setq entry ent))))))) 71 (if entry (cdr entry) default)) 72 (alist-get key alist default remove))) 73 74 ;; NOTE: Define gv expander only if `compat--alist-get' is defined. 75 (when (eval-when-compile (version< emacs-version "26.1")) 76 (gv-define-expander compat--alist-get 77 (lambda (do key alist &optional default remove testfn) 78 (macroexp-let2 macroexp-copyable-p k key 79 (gv-letplace (getter setter) alist 80 (macroexp-let2 nil p `(compat--assoc ,k ,getter ,testfn) 81 (funcall do (if (null default) `(cdr ,p) 82 `(if ,p (cdr ,p) ,default)) 83 (lambda (v) 84 (macroexp-let2 nil v v 85 (let ((set-exp 86 `(if ,p (setcdr ,p ,v) 87 ,(funcall setter 88 `(cons (setq ,p (cons ,k ,v)) 89 ,getter))))) 90 `(progn 91 ,(cond 92 ((null remove) set-exp) 93 ((or (eql v default) 94 (and (eq (car-safe v) 'quote) 95 (eq (car-safe default) 'quote) 96 (eql (cadr v) (cadr default)))) 97 `(if ,p ,(funcall setter `(delq ,p ,getter)))) 98 (t 99 `(cond 100 ((not (eql ,default ,v)) ,set-exp) 101 (,p ,(funcall setter 102 `(delq ,p ,getter)))))) 103 ,v))))))))))) 104 105 (compat-defun string-trim-left (string &optional regexp) ;; <OK> 106 "Handle optional argument REGEXP." 107 :explicit t 108 (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string) 109 (substring string (match-end 0)) 110 string)) 111 112 (compat-defun string-trim-right (string &optional regexp) ;; <OK> 113 "Handle optional argument REGEXP." 114 :explicit t 115 (let ((i (string-match-p 116 (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") 117 string))) 118 (if i (substring string 0 i) string))) 119 120 (compat-defun string-trim (string &optional trim-left trim-right) ;; <OK> 121 "Handle optional arguments TRIM-LEFT and TRIM-RIGHT." 122 :explicit t 123 (compat--string-trim-left 124 (compat--string-trim-right 125 string 126 trim-right) 127 trim-left)) 128 129 (compat-defun caaar (x) ;; <OK> 130 "Return the `car' of the `car' of the `car' of X." 131 (declare (pure t)) 132 (car (car (car x)))) 133 134 (compat-defun caadr (x) ;; <OK> 135 "Return the `car' of the `car' of the `cdr' of X." 136 (declare (pure t)) 137 (car (car (cdr x)))) 138 139 (compat-defun cadar (x) ;; <OK> 140 "Return the `car' of the `cdr' of the `car' of X." 141 (declare (pure t)) 142 (car (cdr (car x)))) 143 144 (compat-defun caddr (x) ;; <OK> 145 "Return the `car' of the `cdr' of the `cdr' of X." 146 (declare (pure t)) 147 (car (cdr (cdr x)))) 148 149 (compat-defun cdaar (x) ;; <OK> 150 "Return the `cdr' of the `car' of the `car' of X." 151 (declare (pure t)) 152 (cdr (car (car x)))) 153 154 (compat-defun cdadr (x) ;; <OK> 155 "Return the `cdr' of the `car' of the `cdr' of X." 156 (declare (pure t)) 157 (cdr (car (cdr x)))) 158 159 (compat-defun cddar (x) ;; <OK> 160 "Return the `cdr' of the `cdr' of the `car' of X." 161 (declare (pure t)) 162 (cdr (cdr (car x)))) 163 164 (compat-defun cdddr (x) ;; <OK> 165 "Return the `cdr' of the `cdr' of the `cdr' of X." 166 (declare (pure t)) 167 (cdr (cdr (cdr x)))) 168 169 (compat-defun caaaar (x) ;; <OK> 170 "Return the `car' of the `car' of the `car' of the `car' of X." 171 (declare (pure t)) 172 (car (car (car (car x))))) 173 174 (compat-defun caaadr (x) ;; <OK> 175 "Return the `car' of the `car' of the `car' of the `cdr' of X." 176 (declare (pure t)) 177 (car (car (car (cdr x))))) 178 179 (compat-defun caadar (x) ;; <OK> 180 "Return the `car' of the `car' of the `cdr' of the `car' of X." 181 (declare (pure t)) 182 (car (car (cdr (car x))))) 183 184 (compat-defun caaddr (x) ;; <OK> 185 "Return the `car' of the `car' of the `cdr' of the `cdr' of X." 186 (declare (pure t)) 187 (car (car (cdr (cdr x))))) 188 189 (compat-defun cadaar (x) ;; <OK> 190 "Return the `car' of the `cdr' of the `car' of the `car' of X." 191 (declare (pure t)) 192 (car (cdr (car (car x))))) 193 194 (compat-defun cadadr (x) ;; <OK> 195 "Return the `car' of the `cdr' of the `car' of the `cdr' of X." 196 (declare (pure t)) 197 (car (cdr (car (cdr x))))) 198 199 (compat-defun caddar (x) ;; <OK> 200 "Return the `car' of the `cdr' of the `cdr' of the `car' of X." 201 (declare (pure t)) 202 (car (cdr (cdr (car x))))) 203 204 (compat-defun cadddr (x) ;; <OK> 205 "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." 206 (declare (pure t)) 207 (car (cdr (cdr (cdr x))))) 208 209 (compat-defun cdaaar (x) ;; <OK> 210 "Return the `cdr' of the `car' of the `car' of the `car' of X." 211 (declare (pure t)) 212 (cdr (car (car (car x))))) 213 214 (compat-defun cdaadr (x) ;; <OK> 215 "Return the `cdr' of the `car' of the `car' of the `cdr' of X." 216 (declare (pure t)) 217 (cdr (car (car (cdr x))))) 218 219 (compat-defun cdadar (x) ;; <OK> 220 "Return the `cdr' of the `car' of the `cdr' of the `car' of X." 221 (declare (pure t)) 222 (cdr (car (cdr (car x))))) 223 224 (compat-defun cdaddr (x) ;; <OK> 225 "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." 226 (declare (pure t)) 227 (cdr (car (cdr (cdr x))))) 228 229 (compat-defun cddaar (x) ;; <OK> 230 "Return the `cdr' of the `cdr' of the `car' of the `car' of X." 231 (declare (pure t)) 232 (cdr (cdr (car (car x))))) 233 234 (compat-defun cddadr (x) ;; <OK> 235 "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." 236 (declare (pure t)) 237 (cdr (cdr (car (cdr x))))) 238 239 (compat-defun cdddar (x) ;; <OK> 240 "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." 241 (declare (pure t)) 242 (cdr (cdr (cdr (car x))))) 243 244 (compat-defun cddddr (x) ;; <OK> 245 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." 246 (declare (pure t)) 247 (cdr (cdr (cdr (cdr x))))) 248 249 (compat-defvar gensym-counter 0 ;; <OK> 250 "Number used to construct the name of the next symbol created by `gensym'.") 251 252 (compat-defun gensym (&optional prefix) ;; <OK> 253 "Return a new uninterned symbol. 254 The name is made by appending `gensym-counter' to PREFIX. 255 PREFIX is a string, and defaults to \"g\"." 256 (let ((num (prog1 gensym-counter 257 (setq gensym-counter 258 (1+ gensym-counter))))) 259 (make-symbol (format "%s%d" (or prefix "g") num)))) 260 261 (compat-defmacro if-let* (varlist then &rest else) ;; <OK> 262 "Bind variables according to VARLIST and evaluate THEN or ELSE. 263 This is like `if-let' but doesn't handle a VARLIST of the form 264 \(SYMBOL SOMETHING) specially." 265 (declare (indent 2) 266 (debug ((&rest [&or symbolp (symbolp form) (form)]) 267 body))) 268 (let ((empty (make-symbol "s")) 269 (last t) list) 270 (dolist (var varlist) 271 (push `(,(if (cdr var) (car var) empty) 272 (and ,last ,(if (cdr var) (cadr var) (car var)))) 273 list) 274 (when (or (cdr var) (consp (car var))) 275 (setq last (caar list)))) 276 `(let* ,(nreverse list) 277 (if ,(caar list) ,then ,@else)))) 278 279 (compat-defmacro when-let* (varlist &rest body) ;; <OK> 280 "Bind variables according to VARLIST and conditionally evaluate BODY. 281 This is like `when-let' but doesn't handle a VARLIST of the form 282 \(SYMBOL SOMETHING) specially." 283 (declare (indent 1) (debug if-let*)) 284 (list 'if-let* varlist (macroexp-progn body))) 285 286 (compat-defmacro and-let* (varlist &rest body) ;; <OK> 287 "Bind variables according to VARLIST and conditionally evaluate BODY. 288 Like `when-let*', except if BODY is empty and all the bindings 289 are non-nil, then the result is non-nil." 290 (declare (indent 1) 291 (debug ((&rest [&or symbolp (symbolp form) (form)]) 292 body))) 293 (let ((empty (make-symbol "s")) 294 (last t) list) 295 (dolist (var varlist) 296 (push `(,(if (cdr var) (car var) empty) 297 (and ,last ,(if (cdr var) (cadr var) (car var)))) 298 list) 299 (when (or (cdr var) (consp (car var))) 300 (setq last (caar list)))) 301 `(let* ,(nreverse list) 302 (if ,(caar list) ,(macroexp-progn (or body '(t))))))) 303 304 ;;;; Defined in files.el 305 306 (compat-defvar mounted-file-systems ;; <OK> 307 (eval-when-compile 308 (if (memq system-type '(windows-nt cygwin)) 309 "^//[^/]+/" 310 (concat 311 "^" (regexp-opt '("/afs/" "/media/" "/mnt" "/net/" "/tmp_mnt/"))))) 312 "File systems that ought to be mounted.") 313 314 (compat-defun file-local-name (file) ;; <OK> 315 "Return the local name component of FILE. 316 This function removes from FILE the specification of the remote host 317 and the method of accessing the host, leaving only the part that 318 identifies FILE locally on the remote system. 319 The returned file name can be used directly as argument of 320 `process-file', `start-file-process', or `shell-command'." 321 (or (file-remote-p file 'localname) file)) 322 323 (compat-defun file-name-quoted-p (name &optional top) ;; <OK> 324 "Handle optional argument TOP." 325 :explicit t 326 (let ((file-name-handler-alist (unless top file-name-handler-alist))) 327 (string-prefix-p "/:" (file-local-name name)))) 328 329 (compat-defun file-name-quote (name &optional top) ;; <OK> 330 "Handle optional argument TOP." 331 :explicit t 332 (let ((file-name-handler-alist (unless top file-name-handler-alist))) 333 (if (string-prefix-p "/:" (file-local-name name)) 334 name 335 (concat (file-remote-p name) "/:" (file-local-name name))))) 336 337 (compat-defun temporary-file-directory () ;; <UNTESTED> 338 "The directory for writing temporary files. 339 In case of a remote `default-directory', this is a directory for 340 temporary files on that remote host. If such a directory does 341 not exist, or `default-directory' ought to be located on a 342 mounted file system (see `mounted-file-systems'), the function 343 returns `default-directory'. 344 For a non-remote and non-mounted `default-directory', the value of 345 the variable `temporary-file-directory' is returned." 346 (let ((handler (find-file-name-handler 347 default-directory 'temporary-file-directory))) 348 (if handler 349 (funcall handler 'temporary-file-directory) 350 (if (string-match mounted-file-systems default-directory) 351 default-directory 352 temporary-file-directory)))) 353 354 (compat-defun make-nearby-temp-file (prefix &optional dir-flag suffix) ;; <UNTESTED> 355 "Create a temporary file as close as possible to `default-directory'. 356 If PREFIX is a relative file name, and `default-directory' is a 357 remote file name or located on a mounted file systems, the 358 temporary file is created in the directory returned by the 359 function `temporary-file-directory'. Otherwise, the function 360 `make-temp-file' is used. PREFIX, DIR-FLAG and SUFFIX have the 361 same meaning as in `make-temp-file'." 362 (let ((handler (find-file-name-handler 363 default-directory 'make-nearby-temp-file))) 364 (if (and handler (not (file-name-absolute-p default-directory))) 365 (funcall handler 'make-nearby-temp-file prefix dir-flag suffix) 366 (let ((temporary-file-directory (temporary-file-directory))) 367 (make-temp-file prefix dir-flag suffix))))) 368 369 (compat-defun file-attribute-type (attributes) ;; <OK> 370 "The type field in ATTRIBUTES returned by `file-attributes'. 371 The value is either t for directory, string (name linked to) for 372 symbolic link, or nil." 373 (nth 0 attributes)) 374 375 (compat-defun file-attribute-link-number (attributes) ;; <OK> 376 "Return the number of links in ATTRIBUTES returned by `file-attributes'." 377 (nth 1 attributes)) 378 379 (compat-defun file-attribute-user-id (attributes) ;; <OK> 380 "The UID field in ATTRIBUTES returned by `file-attributes'. 381 This is either a string or a number. If a string value cannot be 382 looked up, a numeric value, either an integer or a float, is 383 returned." 384 (nth 2 attributes)) 385 386 (compat-defun file-attribute-group-id (attributes) ;; <OK> 387 "The GID field in ATTRIBUTES returned by `file-attributes'. 388 This is either a string or a number. If a string value cannot be 389 looked up, a numeric value, either an integer or a float, is 390 returned." 391 (nth 3 attributes)) 392 393 (compat-defun file-attribute-access-time (attributes) ;; <OK> 394 "The last access time in ATTRIBUTES returned by `file-attributes'. 395 This a Lisp timestamp in the style of `current-time'." 396 (nth 4 attributes)) 397 398 (compat-defun file-attribute-modification-time (attributes) ;; <OK> 399 "The modification time in ATTRIBUTES returned by `file-attributes'. 400 This is the time of the last change to the file's contents, and 401 is a Lisp timestamp in the style of `current-time'." 402 (nth 5 attributes)) 403 404 (compat-defun file-attribute-status-change-time (attributes) ;; <OK> 405 "The status modification time in ATTRIBUTES returned by `file-attributes'. 406 This is the time of last change to the file's attributes: owner 407 and group, access mode bits, etc., and is a Lisp timestamp in the 408 style of `current-time'." 409 (nth 6 attributes)) 410 411 (compat-defun file-attribute-size (attributes) ;; <OK> 412 "The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'." 413 (nth 7 attributes)) 414 415 (compat-defun file-attribute-modes (attributes) ;; <OK> 416 "The file modes in ATTRIBUTES returned by `file-attributes'. 417 This is a string of ten letters or dashes as in ls -l." 418 (nth 8 attributes)) 419 420 (compat-defun file-attribute-inode-number (attributes) ;; <OK> 421 "The inode number in ATTRIBUTES returned by `file-attributes'. 422 It is a nonnegative integer." 423 (nth 10 attributes)) 424 425 (compat-defun file-attribute-device-number (attributes) ;; <OK> 426 "The file system device number in ATTRIBUTES returned by `file-attributes'. 427 It is an integer." 428 (nth 11 attributes)) 429 430 (compat-defun file-attribute-collect (attributes &rest attr-names) ;; <OK> 431 "Return a sublist of ATTRIBUTES returned by `file-attributes'. 432 ATTR-NAMES are symbols with the selected attribute names. 433 434 Valid attribute names are: type, link-number, user-id, group-id, 435 access-time, modification-time, status-change-time, size, modes, 436 inode-number and device-number." 437 (let ((idx '((type . 0) 438 (link-number . 1) 439 (user-id . 2) 440 (group-id . 3) 441 (access-time . 4) 442 (modification-time . 5) 443 (status-change-time . 6) 444 (size . 7) 445 (modes . 8) 446 (inode-number . 10) 447 (device-number . 11))) 448 result) 449 (while attr-names 450 (let ((attr (pop attr-names))) 451 (if (assq attr idx) 452 (push (nth (cdr (assq attr idx)) 453 attributes) 454 result) 455 (error "Wrong attribute name '%S'" attr)))) 456 (nreverse result))) 457 458 ;;;; Defined in image.el 459 460 (compat-defun image-property (image property) ;; <OK> 461 "Return the value of PROPERTY in IMAGE. 462 Properties can be set with 463 464 (setf (image-property IMAGE PROPERTY) VALUE) 465 466 If VALUE is nil, PROPERTY is removed from IMAGE." 467 :feature image 468 (plist-get (cdr image) property)) 469 470 ;;;; Defined in rmc.el 471 472 (compat-defun read-multiple-choice (prompt choices) ;; <OK> 473 "Ask user to select an entry from CHOICES, promting with PROMPT. 474 This function allows to ask the user a multiple-choice question. 475 476 CHOICES should be a list of the form (KEY NAME [DESCRIPTION]). 477 KEY is a character the user should type to select the entry. 478 NAME is a short name for the entry to be displayed while prompting 479 \(if there's no room, it might be shortened). 480 481 NOTE: This is a partial implementation of `read-multiple-choice', that 482 among other things doesn't offer any help and ignores the 483 optional DESCRIPTION field." 484 (let ((options 485 (mapconcat 486 (lambda (opt) 487 (format 488 "[%s] %s" 489 (key-description (string (car opt))) 490 (cadr opt))) 491 choices " ")) 492 choice) 493 (setq prompt (concat prompt " (" options "): ")) 494 (while (not (setq choice (assq (read-event prompt) choices))) 495 (message "Invalid choice") 496 (sit-for 1)) 497 choice)) 498 499 (provide 'compat-26) 500 ;;; compat-26.el ends here