compat-26.el (24063B)
1 ;;; compat-26.el --- Compatibility Layer for Emacs 26.1 -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. 4 5 ;; Author: Philip Kaludercic <philipk@posteo.net> 6 ;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht> 7 ;; URL: https://git.sr.ht/~pkal/compat/ 8 ;; Keywords: lisp 9 10 ;; This program is free software; you can redistribute it and/or modify 11 ;; it under the terms of the GNU General Public License as published by 12 ;; the Free Software Foundation, either version 3 of the License, or 13 ;; (at your option) any later version. 14 15 ;; This program is distributed in the hope that it will be useful, 16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 ;; GNU General Public License for more details. 19 20 ;; You should have received a copy of the GNU General Public License 21 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 22 23 ;;; Commentary: 24 25 ;; Find here the functionality added in Emacs 26.1, needed by older 26 ;; versions. 27 ;; 28 ;; Only load this library if you need to use one of the following 29 ;; functions: 30 ;; 31 ;; - `compat-sort' 32 ;; - `line-number-at-pos' 33 ;; - `compat-alist-get' 34 ;; - `string-trim-left' 35 ;; - `string-trim-right' 36 ;; - `string-trim' 37 38 ;;; Code: 39 40 (require 'compat-macs "compat-macs.el") 41 42 (compat-declare-version "26.1") 43 44 ;;;; Defined in eval.c 45 46 (compat-defun func-arity (func) 47 "Return minimum and maximum number of args allowed for FUNC. 48 FUNC must be a function of some kind. 49 The returned value is a cons cell (MIN . MAX). MIN is the minimum number 50 of args. MAX is the maximum number, or the symbol `many', for a 51 function with `&rest' args, or `unevalled' for a special form." 52 :realname compat--func-arity 53 (cond 54 ((or (null func) (and (symbolp func) (not (fboundp func)))) 55 (signal 'void-function func)) 56 ((and (symbolp func) (not (null func))) 57 (compat--func-arity (symbol-function func))) 58 ((eq (car-safe func) 'macro) 59 (compat--func-arity (cdr func))) 60 ((subrp func) 61 (subr-arity func)) 62 ((memq (car-safe func) '(closure lambda)) 63 ;; See lambda_arity from eval.c 64 (when (eq (car func) 'closure) 65 (setq func (cdr func))) 66 (let ((syms-left (if (consp func) 67 (car func) 68 (signal 'invalid-function func))) 69 (min-args 0) (max-args 0) optional) 70 (catch 'many 71 (dolist (next syms-left) 72 (cond 73 ((not (symbolp next)) 74 (signal 'invalid-function func)) 75 ((eq next '&rest) 76 (throw 'many (cons min-args 'many))) 77 ((eq next '&optional) 78 (setq optional t)) 79 (t (unless optional 80 (setq min-args (1+ min-args))) 81 (setq max-args (1+ max-args))))) 82 (cons min-args max-args)))) 83 ((and (byte-code-function-p func) (numberp (aref func 0))) 84 ;; See get_byte_code_arity from bytecode.c 85 (let ((at (aref func 0))) 86 (cons (logand at 127) 87 (if (= (logand at 128) 0) 88 (ash at -8) 89 'many)))) 90 ((and (byte-code-function-p func) (numberp (aref func 0))) 91 ;; See get_byte_code_arity from bytecode.c 92 (let ((at (aref func 0))) 93 (cons (logand at 127) 94 (if (= (logand at 128) 0) 95 (ash at -8) 96 'many)))) 97 ((and (byte-code-function-p func) (listp (aref func 0))) 98 ;; Based on `byte-compile-make-args-desc', this is required for 99 ;; old versions of Emacs that don't use a integer for the argument 100 ;; list description, per e2abe5a13dffb08d6371b6a611bc39c3a9ac2bc6. 101 (let ((arglist (aref func 0)) (mandatory 0) nonrest) 102 (while (and arglist (not (memq (car arglist) '(&optional &rest)))) 103 (setq mandatory (1+ mandatory)) 104 (setq arglist (cdr arglist))) 105 (setq nonrest mandatory) 106 (when (eq (car arglist) '&optional) 107 (setq arglist (cdr arglist)) 108 (while (and arglist (not (eq (car arglist) '&rest))) 109 (setq nonrest (1+ nonrest)) 110 (setq arglist (cdr arglist)))) 111 (cons mandatory (if arglist 'many nonrest)))) 112 ((autoloadp func) 113 (autoload-do-load func) 114 (compat--func-arity func)) 115 ((signal 'invalid-function func)))) 116 117 ;;;; Defined in fns.c 118 119 (compat-defun assoc (key alist &optional testfn) 120 "Handle the optional argument TESTFN. 121 Equality is defined by the function TESTFN, defaulting to 122 `equal'. TESTFN is called with 2 arguments: a car of an alist 123 element and KEY. With no optional argument, the function behaves 124 just like `assoc'." 125 :prefix t 126 (if testfn 127 (catch 'found 128 (dolist (ent alist) 129 (when (funcall testfn (car ent) key) 130 (throw 'found ent)))) 131 (assoc key alist))) 132 133 (compat-defun mapcan (func sequence) 134 "Apply FUNC to each element of SEQUENCE. 135 Concatenate the results by altering them (using `nconc'). 136 SEQUENCE may be a list, a vector, a boolean vector, or a string." 137 (apply #'nconc (mapcar func sequence))) 138 139 ;;* UNTESTED 140 (compat-defun line-number-at-pos (&optional position absolute) 141 "Handle optional argument ABSOLUTE: 142 143 If the buffer is narrowed, the return value by default counts the lines 144 from the beginning of the accessible portion of the buffer. But if the 145 second optional argument ABSOLUTE is non-nil, the value counts the lines 146 from the absolute start of the buffer, disregarding the narrowing." 147 :prefix t 148 (if absolute 149 (save-restriction 150 (widen) 151 (line-number-at-pos position)) 152 (line-number-at-pos position))) 153 154 ;;;; Defined in subr.el 155 156 (declare-function compat--alist-get-full-elisp "compat-25" 157 (key alist &optional default remove testfn)) 158 (compat-defun alist-get (key alist &optional default remove testfn) 159 "Handle TESTFN manually." 160 :realname compat--alist-get-handle-testfn 161 :prefix t 162 (if testfn 163 (compat--alist-get-full-elisp key alist default remove testfn) 164 (alist-get key alist default remove))) 165 166 (gv-define-expander compat-alist-get 167 (lambda (do key alist &optional default remove testfn) 168 (macroexp-let2 macroexp-copyable-p k key 169 (gv-letplace (getter setter) alist 170 (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq))) 171 (compat-assoc ,k ,getter ,testfn) 172 (assq ,k ,getter)) 173 (funcall do (if (null default) `(cdr ,p) 174 `(if ,p (cdr ,p) ,default)) 175 (lambda (v) 176 (macroexp-let2 nil v v 177 (let ((set-exp 178 `(if ,p (setcdr ,p ,v) 179 ,(funcall setter 180 `(cons (setq ,p (cons ,k ,v)) 181 ,getter))))) 182 `(progn 183 ,(cond 184 ((null remove) set-exp) 185 ((or (eql v default) 186 (and (eq (car-safe v) 'quote) 187 (eq (car-safe default) 'quote) 188 (eql (cadr v) (cadr default)))) 189 `(if ,p ,(funcall setter `(delq ,p ,getter)))) 190 (t 191 `(cond 192 ((not (eql ,default ,v)) ,set-exp) 193 (,p ,(funcall setter 194 `(delq ,p ,getter)))))) 195 ,v)))))))))) 196 197 (compat-defun string-trim-left (string &optional regexp) 198 "Trim STRING of leading string matching REGEXP. 199 200 REGEXP defaults to \"[ \\t\\n\\r]+\"." 201 :realname compat--string-trim-left 202 :prefix t 203 (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string) 204 (substring string (match-end 0)) 205 string)) 206 207 (compat-defun string-trim-right (string &optional regexp) 208 "Trim STRING of trailing string matching REGEXP. 209 210 REGEXP defaults to \"[ \\t\\n\\r]+\"." 211 :realname compat--string-trim-right 212 :prefix t 213 (let ((i (string-match-p 214 (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") 215 string))) 216 (if i (substring string 0 i) string))) 217 218 (compat-defun string-trim (string &optional trim-left trim-right) 219 "Trim STRING of leading with and trailing matching TRIM-LEFT and TRIM-RIGHT. 220 221 TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." 222 :prefix t 223 ;; `string-trim-left' and `string-trim-right' were moved from subr-x 224 ;; to subr in Emacs 27, so to avoid loading subr-x we use the 225 ;; compatibility function here: 226 (compat--string-trim-left 227 (compat--string-trim-right 228 string 229 trim-right) 230 trim-left)) 231 232 (compat-defun caaar (x) 233 "Return the `car' of the `car' of the `car' of X." 234 (declare (pure t)) 235 (car (car (car x)))) 236 237 (compat-defun caadr (x) 238 "Return the `car' of the `car' of the `cdr' of X." 239 (declare (pure t)) 240 (car (car (cdr x)))) 241 242 (compat-defun cadar (x) 243 "Return the `car' of the `cdr' of the `car' of X." 244 (declare (pure t)) 245 (car (cdr (car x)))) 246 247 (compat-defun caddr (x) 248 "Return the `car' of the `cdr' of the `cdr' of X." 249 (declare (pure t)) 250 (car (cdr (cdr x)))) 251 252 (compat-defun cdaar (x) 253 "Return the `cdr' of the `car' of the `car' of X." 254 (declare (pure t)) 255 (cdr (car (car x)))) 256 257 (compat-defun cdadr (x) 258 "Return the `cdr' of the `car' of the `cdr' of X." 259 (declare (pure t)) 260 (cdr (car (cdr x)))) 261 262 (compat-defun cddar (x) 263 "Return the `cdr' of the `cdr' of the `car' of X." 264 (declare (pure t)) 265 (cdr (cdr (car x)))) 266 267 (compat-defun cdddr (x) 268 "Return the `cdr' of the `cdr' of the `cdr' of X." 269 (declare (pure t)) 270 (cdr (cdr (cdr x)))) 271 272 (compat-defun caaaar (x) 273 "Return the `car' of the `car' of the `car' of the `car' of X." 274 (declare (pure t)) 275 (car (car (car (car x))))) 276 277 (compat-defun caaadr (x) 278 "Return the `car' of the `car' of the `car' of the `cdr' of X." 279 (declare (pure t)) 280 (car (car (car (cdr x))))) 281 282 (compat-defun caadar (x) 283 "Return the `car' of the `car' of the `cdr' of the `car' of X." 284 (declare (pure t)) 285 (car (car (cdr (car x))))) 286 287 (compat-defun caaddr (x) 288 "Return the `car' of the `car' of the `cdr' of the `cdr' of X." 289 (declare (pure t)) 290 (car (car (cdr (cdr x))))) 291 292 (compat-defun cadaar (x) 293 "Return the `car' of the `cdr' of the `car' of the `car' of X." 294 (declare (pure t)) 295 (car (cdr (car (car x))))) 296 297 (compat-defun cadadr (x) 298 "Return the `car' of the `cdr' of the `car' of the `cdr' of X." 299 (declare (pure t)) 300 (car (cdr (car (cdr x))))) 301 302 (compat-defun caddar (x) 303 "Return the `car' of the `cdr' of the `cdr' of the `car' of X." 304 (declare (pure t)) 305 (car (cdr (cdr (car x))))) 306 307 (compat-defun cadddr (x) 308 "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." 309 (declare (pure t)) 310 (car (cdr (cdr (cdr x))))) 311 312 (compat-defun cdaaar (x) 313 "Return the `cdr' of the `car' of the `car' of the `car' of X." 314 (declare (pure t)) 315 (cdr (car (car (car x))))) 316 317 (compat-defun cdaadr (x) 318 "Return the `cdr' of the `car' of the `car' of the `cdr' of X." 319 (declare (pure t)) 320 (cdr (car (car (cdr x))))) 321 322 (compat-defun cdadar (x) 323 "Return the `cdr' of the `car' of the `cdr' of the `car' of X." 324 (declare (pure t)) 325 (cdr (car (cdr (car x))))) 326 327 (compat-defun cdaddr (x) 328 "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." 329 (declare (pure t)) 330 (cdr (car (cdr (cdr x))))) 331 332 (compat-defun cddaar (x) 333 "Return the `cdr' of the `cdr' of the `car' of the `car' of X." 334 (declare (pure t)) 335 (cdr (cdr (car (car x))))) 336 337 (compat-defun cddadr (x) 338 "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." 339 (declare (pure t)) 340 (cdr (cdr (car (cdr x))))) 341 342 (compat-defun cdddar (x) 343 "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." 344 (declare (pure t)) 345 (cdr (cdr (cdr (car x))))) 346 347 (compat-defun cddddr (x) 348 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." 349 (declare (pure t)) 350 (cdr (cdr (cdr (cdr x))))) 351 352 (compat-defvar gensym-counter 0 353 "Number used to construct the name of the next symbol created by `gensym'.") 354 355 (compat-defun gensym (&optional prefix) 356 "Return a new uninterned symbol. 357 The name is made by appending `gensym-counter' to PREFIX. 358 PREFIX is a string, and defaults to \"g\"." 359 (let ((num (prog1 gensym-counter 360 (setq gensym-counter 361 (1+ gensym-counter))))) 362 (make-symbol (format "%s%d" (or prefix "g") num)))) 363 364 ;;;; Defined in files.el 365 366 (declare-function temporary-file-directory nil) 367 368 ;;* UNTESTED 369 (compat-defun make-nearby-temp-file (prefix &optional dir-flag suffix) 370 "Create a temporary file as close as possible to `default-directory'. 371 If PREFIX is a relative file name, and `default-directory' is a 372 remote file name or located on a mounted file systems, the 373 temporary file is created in the directory returned by the 374 function `temporary-file-directory'. Otherwise, the function 375 `make-temp-file' is used. PREFIX, DIR-FLAG and SUFFIX have the 376 same meaning as in `make-temp-file'." 377 (let ((handler (find-file-name-handler 378 default-directory 'make-nearby-temp-file))) 379 (if (and handler (not (file-name-absolute-p default-directory))) 380 (funcall handler 'make-nearby-temp-file prefix dir-flag suffix) 381 (let ((temporary-file-directory (temporary-file-directory))) 382 (make-temp-file prefix dir-flag suffix))))) 383 384 (compat-defvar mounted-file-systems 385 (eval-when-compile 386 (if (memq system-type '(windows-nt cygwin)) 387 "^//[^/]+/" 388 (concat 389 "^" (regexp-opt '("/afs/" "/media/" "/mnt" "/net/" "/tmp_mnt/"))))) 390 "File systems that ought to be mounted.") 391 392 (compat-defun file-local-name (file) 393 "Return the local name component of FILE. 394 This function removes from FILE the specification of the remote host 395 and the method of accessing the host, leaving only the part that 396 identifies FILE locally on the remote system. 397 The returned file name can be used directly as argument of 398 `process-file', `start-file-process', or `shell-command'." 399 :realname compat--file-local-name 400 (or (file-remote-p file 'localname) file)) 401 402 (compat-defun file-name-quoted-p (name &optional top) 403 "Whether NAME is quoted with prefix \"/:\". 404 If NAME is a remote file name and TOP is nil, check the local part of NAME." 405 :realname compat--file-name-quoted-p 406 (let ((file-name-handler-alist (unless top file-name-handler-alist))) 407 (string-prefix-p "/:" (compat--file-local-name name)))) 408 409 (compat-defun file-name-quote (name &optional top) 410 "Add the quotation prefix \"/:\" to file NAME. 411 If NAME is a remote file name and TOP is nil, the local part of 412 NAME is quoted. If NAME is already a quoted file name, NAME is 413 returned unchanged." 414 (let ((file-name-handler-alist (unless top file-name-handler-alist))) 415 (if (compat--file-name-quoted-p name top) 416 name 417 (concat (file-remote-p name) "/:" (compat--file-local-name name))))) 418 419 ;;* UNTESTED 420 (compat-defun temporary-file-directory () 421 "The directory for writing temporary files. 422 In case of a remote `default-directory', this is a directory for 423 temporary files on that remote host. If such a directory does 424 not exist, or `default-directory' ought to be located on a 425 mounted file system (see `mounted-file-systems'), the function 426 returns `default-directory'. 427 For a non-remote and non-mounted `default-directory', the value of 428 the variable `temporary-file-directory' is returned." 429 (let ((handler (find-file-name-handler 430 default-directory 'temporary-file-directory))) 431 (if handler 432 (funcall handler 'temporary-file-directory) 433 (if (string-match mounted-file-systems default-directory) 434 default-directory 435 temporary-file-directory)))) 436 437 ;;* UNTESTED 438 (compat-defun file-attribute-type (attributes) 439 "The type field in ATTRIBUTES returned by `file-attributes'. 440 The value is either t for directory, string (name linked to) for 441 symbolic link, or nil." 442 (nth 0 attributes)) 443 444 ;;* UNTESTED 445 (compat-defun file-attribute-link-number (attributes) 446 "Return the number of links in ATTRIBUTES returned by `file-attributes'." 447 (nth 1 attributes)) 448 449 ;;* UNTESTED 450 (compat-defun file-attribute-user-id (attributes) 451 "The UID field in ATTRIBUTES returned by `file-attributes'. 452 This is either a string or a number. If a string value cannot be 453 looked up, a numeric value, either an integer or a float, is 454 returned." 455 (nth 2 attributes)) 456 457 ;;* UNTESTED 458 (compat-defun file-attribute-group-id (attributes) 459 "The GID field in ATTRIBUTES returned by `file-attributes'. 460 This is either a string or a number. If a string value cannot be 461 looked up, a numeric value, either an integer or a float, is 462 returned." 463 (nth 3 attributes)) 464 465 ;;* UNTESTED 466 (compat-defun file-attribute-access-time (attributes) 467 "The last access time in ATTRIBUTES returned by `file-attributes'. 468 This a Lisp timestamp in the style of `current-time'." 469 (nth 4 attributes)) 470 471 ;;* UNTESTED 472 (compat-defun file-attribute-modification-time (attributes) 473 "The modification time in ATTRIBUTES returned by `file-attributes'. 474 This is the time of the last change to the file's contents, and 475 is a Lisp timestamp in the style of `current-time'." 476 (nth 5 attributes)) 477 478 ;;* UNTESTED 479 (compat-defun file-attribute-status-change-time (attributes) 480 "The status modification time in ATTRIBUTES returned by `file-attributes'. 481 This is the time of last change to the file's attributes: owner 482 and group, access mode bits, etc., and is a Lisp timestamp in the 483 style of `current-time'." 484 (nth 6 attributes)) 485 486 ;;* UNTESTED 487 (compat-defun file-attribute-size (attributes) 488 "The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'." 489 (nth 7 attributes)) 490 491 ;;* UNTESTED 492 (compat-defun file-attribute-modes (attributes) 493 "The file modes in ATTRIBUTES returned by `file-attributes'. 494 This is a string of ten letters or dashes as in ls -l." 495 (nth 8 attributes)) 496 497 ;;* UNTESTED 498 (compat-defun file-attribute-inode-number (attributes) 499 "The inode number in ATTRIBUTES returned by `file-attributes'. 500 It is a nonnegative integer." 501 (nth 10 attributes)) 502 503 ;;* UNTESTED 504 (compat-defun file-attribute-device-number (attributes) 505 "The file system device number in ATTRIBUTES returned by `file-attributes'. 506 It is an integer." 507 (nth 11 attributes)) 508 509 (compat-defun file-attribute-collect (attributes &rest attr-names) 510 "Return a sublist of ATTRIBUTES returned by `file-attributes'. 511 ATTR-NAMES are symbols with the selected attribute names. 512 513 Valid attribute names are: type, link-number, user-id, group-id, 514 access-time, modification-time, status-change-time, size, modes, 515 inode-number and device-number." 516 (let ((idx '((type . 0) 517 (link-number . 1) 518 (user-id . 2) 519 (group-id . 3) 520 (access-time . 4) 521 (modification-time . 5) 522 (status-change-time . 6) 523 (size . 7) 524 (modes . 8) 525 (inode-number . 10) 526 (device-number . 11))) 527 result) 528 (while attr-names 529 (let ((attr (pop attr-names))) 530 (if (assq attr idx) 531 (push (nth (cdr (assq attr idx)) 532 attributes) 533 result) 534 (error "Wrong attribute name '%S'" attr)))) 535 (nreverse result))) 536 537 ;;;; Defined in subr-x.el 538 539 (compat-defmacro if-let* (varlist then &rest else) 540 "Bind variables according to VARLIST and evaluate THEN or ELSE. 541 This is like `if-let' but doesn't handle a VARLIST of the form 542 \(SYMBOL SOMETHING) specially." 543 :realname compat--if-let* 544 :feature 'subr-x 545 (declare (indent 2) 546 (debug ((&rest [&or symbolp (symbolp form) (form)]) 547 body))) 548 (let ((empty (make-symbol "s")) 549 (last t) list) 550 (dolist (var varlist) 551 (push `(,(if (cdr var) (car var) empty) 552 (and ,last ,(or (cadr var) (car var)))) 553 list) 554 (when (or (cdr var) (consp (car var))) 555 (setq last (caar list)))) 556 `(let* ,(nreverse list) 557 (if ,(caar list) ,then ,@else)))) 558 559 (compat-defmacro when-let* (varlist &rest body) 560 "Bind variables according to VARLIST and conditionally evaluate BODY. 561 This is like `when-let' but doesn't handle a VARLIST of the form 562 \(SYMBOL SOMETHING) specially." 563 ;; :feature 'subr-x 564 (declare (indent 1) (debug if-let*)) 565 (let ((empty (make-symbol "s")) 566 (last t) list) 567 (dolist (var varlist) 568 (push `(,(if (cdr var) (car var) empty) 569 (and ,last ,(or (cadr var) (car var)))) 570 list) 571 (when (or (cdr var) (consp (car var))) 572 (setq last (caar list)))) 573 `(let* ,(nreverse list) 574 (when ,(caar list) ,@body)))) 575 576 (compat-defmacro and-let* (varlist &rest body) 577 "Bind variables according to VARLIST and conditionally evaluate BODY. 578 Like `when-let*', except if BODY is empty and all the bindings 579 are non-nil, then the result is non-nil." 580 :feature 'subr-x 581 (declare (indent 1) (debug if-let*)) 582 (let ((empty (make-symbol "s")) 583 (last t) list) 584 (dolist (var varlist) 585 (push `(,(if (cdr var) (car var) empty) 586 (and ,last ,(or (cadr var) (car var)))) 587 list) 588 (when (or (cdr var) (consp (car var))) 589 (setq last (caar list)))) 590 `(let* ,(nreverse list) 591 (if ,(caar list) ,(macroexp-progn (or body '(t))))))) 592 593 ;;;; Defined in image.el 594 595 ;;* UNTESTED 596 (compat-defun image-property (image property) 597 "Return the value of PROPERTY in IMAGE. 598 Properties can be set with 599 600 (setf (image-property IMAGE PROPERTY) VALUE) 601 602 If VALUE is nil, PROPERTY is removed from IMAGE." 603 (plist-get (cdr image) property)) 604 605 ;;* UNTESTED 606 (unless (get 'image-property 'gv-expander) 607 (gv-define-setter image-property (image property value) 608 (let ((image* (make-symbol "image")) 609 (property* (make-symbol "property")) 610 (value* (make-symbol "value"))) 611 `(let ((,image* ,image) 612 (,property* ,property) 613 (,value* ,value)) 614 (if 615 (null ,value*) 616 (while 617 (cdr ,image*) 618 (if 619 (eq 620 (cadr ,image*) 621 ,property*) 622 (setcdr ,image* 623 (cdddr ,image*)) 624 (setq ,image* 625 (cddr ,image*)))) 626 (setcdr ,image* 627 (plist-put 628 (cdr ,image*) 629 ,property* ,value*))))))) 630 631 ;;;; Defined in rmc.el 632 633 ;;*UNTESTED 634 (compat-defun read-multiple-choice 635 (prompt choices &optional _help-string _show-help long-form) 636 "Ask user to select an entry from CHOICES, promting with PROMPT. 637 This function allows to ask the user a multiple-choice question. 638 639 CHOICES should be a list of the form (KEY NAME [DESCRIPTION]). 640 KEY is a character the user should type to select the entry. 641 NAME is a short name for the entry to be displayed while prompting 642 \(if there's no room, it might be shortened). 643 644 If LONG-FORM, do a `completing-read' over the NAME elements in 645 CHOICES instead." 646 :note "This is a partial implementation of `read-multiple-choice', that 647 among other things doesn't offer any help and ignores the 648 optional DESCRIPTION field." 649 (if long-form 650 (let ((options (mapconcat #'cadr choices "/")) 651 choice) 652 (setq prompt (concat prompt " (" options "): ")) 653 (setq choice (completing-read prompt (mapcar #'cadr choices) nil t)) 654 (catch 'found 655 (dolist (option choices) 656 (when (string= choice (cadr option)) 657 (throw 'found option))) 658 (error "Invalid choice"))) 659 (let ((options 660 (mapconcat 661 (lambda (opt) 662 (format 663 "[%s] %s" 664 (key-description (string (car opt))) 665 (cadr opt))) 666 choices " ")) 667 choice) 668 (setq prompt (concat prompt " (" options "): ")) 669 (while (not (setq choice (assq (read-char prompt) choices))) 670 (message "Invalid choice") 671 (sit-for 1)) 672 choice))) 673 674 (compat--inhibit-prefixed (provide 'compat-26)) 675 ;;; compat-26.el ends here