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