compat-27.el (37106B)
1 ;;; compat-27.el --- Functionality added in Emacs 27.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 27.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-26 "26.1") 26 27 (compat-version "27.1") 28 29 ;;;; Defined in fns.c 30 31 (compat-defun proper-list-p (object) ;; <compat-tests:proper-list-p> 32 "Return OBJECT's length if it is a proper list, nil otherwise. 33 A proper list is neither circular nor dotted (i.e., its last cdr 34 is nil)." 35 (if (eval-when-compile (< emacs-major-version 26)) 36 ;; On older Emacs than 26.1 use Tortoise and Hare algorithm 37 (when (listp object) 38 (catch 'cycle 39 (let ((hare object) (tortoise object) 40 (max 2) (q 2)) 41 (while (consp hare) 42 (setq hare (cdr hare)) 43 (when (and (or (/= 0 (setq q (1- q))) 44 (ignore 45 (setq max (ash max 1) 46 q max 47 tortoise hare))) 48 (eq hare tortoise)) 49 (throw 'cycle nil))) 50 (and (null hare) (length object))))) 51 ;; Errors on 26.1 and newer 52 (and (listp object) (ignore-errors (length object))))) 53 54 (compat-defun string-distance (string1 string2 &optional bytecompare) ;; <compat-tests:string-distance> 55 "Return Levenshtein distance between STRING1 and STRING2. 56 The distance is the number of deletions, insertions, and substitutions 57 required to transform STRING1 into STRING2. 58 If BYTECOMPARE is nil or omitted, compute distance in terms of characters. 59 If BYTECOMPARE is non-nil, compute distance in terms of bytes. 60 Letter-case is significant, but text properties are ignored." 61 ;; https://en.wikipedia.org/wiki/Levenshtein_distance 62 (let ((s1 (if bytecompare 63 (encode-coding-string string1 'raw-text) 64 (concat string1 ""))) 65 (s2 (if bytecompare 66 (encode-coding-string string2 'raw-text) 67 string2))) 68 (let* ((len1 (length s1)) 69 (len2 (length s2)) 70 (column (make-vector (1+ len1) 0))) 71 (dotimes (y len1) 72 (setf (aref column (1+ y)) y)) 73 (dotimes (x len2) 74 (setf (aref column 0) (1+ x)) 75 (let ((lastdiag x) olddiag) 76 (dotimes (y len1) 77 (setf olddiag (aref column (1+ y)) 78 (aref column (1+ y)) 79 (min (+ (if (= (aref s1 y) (aref s2 x)) 0 1) 80 lastdiag) 81 (1+ (aref column (1+ y))) 82 (1+ (aref column y))) 83 lastdiag olddiag)))) 84 (aref column len1)))) 85 86 ;;;; Defined in window.c 87 88 (compat-defun recenter (&optional arg redisplay) ;; <compat-tests:recenter> 89 "Handle optional argument REDISPLAY." 90 :extended t 91 (recenter arg) 92 (when (and redisplay recenter-redisplay) 93 (redisplay))) 94 95 ;;;; Defined in keymap.c 96 97 (compat-defun lookup-key (keymap key &optional accept-default) ;; <compat-tests:lookup-key> 98 "Allow for KEYMAP to be a list of keymaps." 99 :extended t 100 (cond 101 ((keymapp keymap) 102 (lookup-key keymap key accept-default)) 103 ((listp keymap) 104 (catch 'found 105 (dolist (map keymap) 106 (when-let ((fn (lookup-key map key accept-default))) 107 (throw 'found fn))))) 108 ((signal 'wrong-type-argument (list 'keymapp keymap))))) 109 110 ;;;; Defined in timefns.c 111 112 (compat-defun time-equal-p (t1 t2) ;; <compat-tests:time-equal-p> 113 "Return non-nil if time value T1 is equal to time value T2. 114 A nil value for either argument stands for the current time. 115 116 NOTE: This function is not as accurate as the actual `time-equal-p'." 117 (cond 118 ((eq t1 t2)) 119 ((and (consp t1) (consp t2)) 120 (equal t1 t2)) 121 (t 122 ;; Due to inaccuracies and the relatively slow evaluating of 123 ;; Emacs Lisp compared to C, we allow for slight inaccuracies 124 ;; (less than a millisecond) when comparing time values. 125 (< (abs (- (float-time t1) (float-time t2))) 126 (if (and t1 t2) 1e-6 1e-5))))) 127 128 ;;;; Defined in subr.el 129 130 (compat-defalias fixnump integerp) ;; <compat-tests:fixnump> 131 (compat-defalias bignump ignore) ;; <compat-tests:bignump> 132 133 (compat-defmacro setq-local (&rest pairs) ;; <compat-tests:setq-local> 134 "Handle multiple assignments." 135 :extended t 136 (unless (zerop (mod (length pairs) 2)) 137 (error "PAIRS must have an even number of variable/value members")) 138 (let (body) 139 (while pairs 140 (let* ((sym (pop pairs)) 141 (val (pop pairs))) 142 (unless (symbolp sym) 143 (error "Attempting to set a non-symbol: %s" (car pairs))) 144 (push `(set (make-local-variable ',sym) ,val) 145 body))) 146 (cons 'progn (nreverse body)))) 147 148 (compat-defmacro ignore-error (condition &rest body) ;; <compat-tests:ignore-error> 149 "Execute BODY; if the error CONDITION occurs, return nil. 150 Otherwise, return result of last form in BODY. 151 152 CONDITION can also be a list of error conditions." 153 (declare (debug t) (indent 1)) 154 `(condition-case nil (progn ,@body) (,condition nil))) 155 156 (compat-defmacro dolist-with-progress-reporter (spec reporter-or-message &rest body) ;; <compat-tests:dolist-with-progress-reporter> 157 "Loop over a list and report progress in the echo area. 158 Evaluate BODY with VAR bound to each car from LIST, in turn. 159 Then evaluate RESULT to get return value, default nil. 160 161 REPORTER-OR-MESSAGE is a progress reporter object or a string. In the latter 162 case, use this string to create a progress reporter. 163 164 At each iteration, print the reporter message followed by progress 165 percentage in the echo area. After the loop is finished, 166 print the reporter message followed by the word \"done\". 167 168 \(fn (VAR LIST [RESULT]) REPORTER-OR-MESSAGE BODY...)" 169 (declare (indent 2) (debug ((symbolp form &optional form) form body))) 170 (let ((prep (make-symbol "--dolist-progress-reporter--")) 171 (count (make-symbol "--dolist-count--")) 172 (list (make-symbol "--dolist-list--"))) 173 `(let ((,prep ,reporter-or-message) 174 (,count 0) 175 (,list ,(cadr spec))) 176 (when (stringp ,prep) 177 (setq ,prep (make-progress-reporter ,prep 0 (length ,list)))) 178 (dolist (,(car spec) ,list) 179 ,@body 180 (progress-reporter-update ,prep (setq ,count (1+ ,count)))) 181 (progress-reporter-done ,prep) 182 (or ,@(cdr (cdr spec)) nil)))) 183 184 (compat-defun flatten-tree (tree) ;; <compat-tests:flatten-tree> 185 "Return a \"flattened\" copy of TREE. 186 In other words, return a list of the non-nil terminal nodes, or 187 leaves, of the tree of cons cells rooted at TREE. Leaves in the 188 returned list are in the same order as in TREE. 189 190 \(flatten-tree \\='(1 (2 . 3) nil (4 5 (6)) 7)) 191 => (1 2 3 4 5 6 7)" 192 (let (elems) 193 (while (consp tree) 194 (let ((elem (pop tree))) 195 (while (consp elem) 196 (push (cdr elem) tree) 197 (setq elem (car elem))) 198 (if elem (push elem elems)))) 199 (if tree (push tree elems)) 200 (nreverse elems))) 201 202 (compat-defun xor (cond1 cond2) ;; <compat-tests:xor> 203 "Return the boolean exclusive-or of COND1 and COND2. 204 If only one of the arguments is non-nil, return it; otherwise 205 return nil." 206 (declare (pure t) (side-effect-free error-free)) 207 (cond ((not cond1) cond2) 208 ((not cond2) cond1))) 209 210 (compat-defvar regexp-unmatchable "\\`a\\`" ;; <compat-tests:regexp-unmatchable> 211 "Standard regexp guaranteed not to match any string at all." 212 :constant t) 213 214 (compat-defun assoc-delete-all (key alist &optional test) ;; <compat-tests:assoc-delete-all> 215 "Handle optional argument TEST." 216 :extended "26.2" 217 (unless test (setq test #'equal)) 218 (while (and (consp (car alist)) 219 (funcall test (caar alist) key)) 220 (setq alist (cdr alist))) 221 (let ((tail alist) tail-cdr) 222 (while (setq tail-cdr (cdr tail)) 223 (if (and (consp (car tail-cdr)) 224 (funcall test (caar tail-cdr) key)) 225 (setcdr tail (cdr tail-cdr)) 226 (setq tail tail-cdr)))) 227 alist) 228 229 (compat-defvar major-mode--suspended nil ;; <compat-tests:major-mode-suspend> 230 "Suspended major mode." 231 :local permanent) 232 233 (compat-defun major-mode-suspend () ;; <compat-tests:major-mode-suspend> 234 "Exit current major mode, remembering it." 235 (let* ((prev-major-mode (or major-mode--suspended 236 (unless (eq major-mode 'fundamental-mode) 237 major-mode)))) 238 (kill-all-local-variables) 239 (setq-local major-mode--suspended prev-major-mode))) 240 241 (compat-defun major-mode-restore (&optional avoided-modes) ;; <compat-tests:major-mode-suspend> 242 "Restore major mode earlier suspended with `major-mode-suspend'. 243 If there was no earlier suspended major mode, then fallback to `normal-mode', 244 though trying to avoid AVOIDED-MODES." 245 (if major-mode--suspended 246 (funcall (prog1 major-mode--suspended 247 (kill-local-variable 'major-mode--suspended))) 248 (let ((auto-mode-alist 249 (let ((alist (copy-sequence auto-mode-alist))) 250 (dolist (mode avoided-modes) 251 (setq alist (rassq-delete-all mode alist))) 252 alist)) 253 (magic-fallback-mode-alist 254 (let ((alist (copy-sequence magic-fallback-mode-alist))) 255 (dolist (mode avoided-modes) 256 (setq alist (rassq-delete-all mode alist))) 257 alist))) 258 (normal-mode)))) 259 260 (compat-defun read-char-from-minibuffer-insert-char () ;; <compat-tests:read-char-from-minibuffer> 261 "Insert the character you type into the minibuffer and exit minibuffer. 262 Discard all previous input before inserting and exiting the minibuffer." 263 (interactive) 264 (when (minibufferp) 265 (delete-minibuffer-contents) 266 (insert last-command-event) 267 (exit-minibuffer))) 268 269 (compat-defun read-char-from-minibuffer-insert-other () ;; <compat-tests:read-char-from-minibuffer> 270 "Reject a disallowed character typed into the minibuffer. 271 This command is intended to be bound to keys that users are not 272 allowed to type into the minibuffer. When the user types any 273 such key, this command discard all minibuffer input and displays 274 an error message." 275 (interactive) 276 (when (minibufferp) 277 (delete-minibuffer-contents) 278 (ding) 279 (discard-input) 280 (minibuffer-message "Wrong answer") 281 (sit-for 2))) 282 283 (compat-defvar read-char-history nil ;; <compat-tests:read-char-from-minibuffer> 284 "The default history for the `read-char-from-minibuffer' function.") 285 286 (compat-defvar read-char-from-minibuffer-map ;; <compat-tests:read-char-from-minibuffer> 287 (let ((map (make-sparse-keymap))) 288 (set-keymap-parent map minibuffer-local-map) 289 (define-key map [remap self-insert-command] #'read-char-from-minibuffer-insert-char) 290 (define-key map [remap exit-minibuffer] #'read-char-from-minibuffer-insert-other) 291 map) 292 "Keymap for the `read-char-from-minibuffer' function.") 293 294 (compat-defvar read-char-from-minibuffer-map-hash ;; <compat-tests:read-char-from-minibuffer> 295 (make-hash-table :test 'equal) 296 "Hash table of keymaps used by `read-char-from-minibuffer'." 297 :constant t) 298 299 (compat-defun read-char-from-minibuffer (prompt &optional chars history) ;; <compat-tests:read-char-from-minibuffer> 300 "Read a character from the minibuffer, prompting for it with PROMPT. 301 Like `read-char', but uses the minibuffer to read and return a character. 302 Optional argument CHARS, if non-nil, should be a list of characters; 303 the function will ignore any input that is not one of CHARS. 304 Optional argument HISTORY, if non-nil, should be a symbol that 305 specifies the history list variable to use for navigating in input 306 history using \\`M-p' and \\`M-n', with \\`RET' to select a character from 307 history. 308 If you bind the variable `help-form' to a non-nil value 309 while calling this function, then pressing `help-char' 310 causes it to evaluate `help-form' and display the result. 311 There is no need to explicitly add `help-char' to CHARS; 312 `help-char' is bound automatically to `help-form-show'." 313 (let* ((map (if (consp chars) 314 (or (gethash (list help-form (cons help-char chars)) 315 read-char-from-minibuffer-map-hash) 316 (let ((map (make-sparse-keymap)) 317 (msg help-form)) 318 (set-keymap-parent map read-char-from-minibuffer-map) 319 ;; If we have a dynamically bound `help-form' 320 ;; here, then the `C-h' (i.e., `help-char') 321 ;; character should output that instead of 322 ;; being a command char. 323 (when help-form 324 (define-key map (vector help-char) 325 (lambda () 326 (interactive) 327 (let ((help-form msg)) ; lexically bound msg 328 (help-form-show))))) 329 (dolist (char chars) 330 (define-key map (vector char) 331 #'read-char-from-minibuffer-insert-char)) 332 (define-key map [remap self-insert-command] 333 #'read-char-from-minibuffer-insert-other) 334 (puthash (list help-form (cons help-char chars)) 335 map read-char-from-minibuffer-map-hash) 336 map)) 337 read-char-from-minibuffer-map)) 338 ;; Protect this-command when called from pre-command-hook (bug#45029) 339 (this-command this-command) 340 (result (read-from-minibuffer prompt nil map nil (or history t))) 341 (char 342 (if (> (length result) 0) 343 ;; We have a string (with one character), so return the first one. 344 (elt result 0) 345 ;; The default value is RET. 346 (when history (push "\r" (symbol-value history))) 347 ?\r))) 348 ;; Display the question with the answer. 349 (message "%s%s" prompt (char-to-string char)) 350 char)) 351 352 ;;;; Defined in simple.el 353 354 (compat-guard (not (fboundp 'decoded-time-second)) ;; <compat-tests:decoded-time> 355 (cl-defstruct (decoded-time 356 (:constructor nil) 357 (:copier nil) 358 (:type list)) 359 (second nil :documentation "\ 360 This is an integer or a Lisp timestamp (TICKS . HZ) representing a nonnegative 361 number of seconds less than 61. (If not less than 60, it is a leap second, 362 which only some operating systems support.)") 363 (minute nil :documentation "This is an integer between 0 and 59 (inclusive).") 364 (hour nil :documentation "This is an integer between 0 and 23 (inclusive).") 365 (day nil :documentation "This is an integer between 1 and 31 (inclusive).") 366 (month nil :documentation "\ 367 This is an integer between 1 and 12 (inclusive). January is 1.") 368 (year nil :documentation "This is a four digit integer.") 369 (weekday nil :documentation "\ 370 This is a number between 0 and 6, and 0 is Sunday.") 371 (dst -1 :documentation "\ 372 This is t if daylight saving time is in effect, nil if it is not 373 in effect, and -1 if daylight saving information is not available. 374 Also see `decoded-time-dst'.") 375 (zone nil :documentation "\ 376 This is an integer indicating the UTC offset in seconds, i.e., 377 the number of seconds east of Greenwich."))) 378 379 (compat-defun minibuffer-history-value () ;; <compat-tests:minibuffer-history-value> 380 "Return the value of the minibuffer input history list. 381 If `minibuffer-history-variable' points to a buffer-local variable and 382 the minibuffer is active, return the buffer-local value for the buffer 383 that was current when the minibuffer was activated." 384 (buffer-local-value minibuffer-history-variable 385 (window-buffer (minibuffer-selected-window)))) 386 387 ;;;; Defined in minibuffer.el 388 389 (compat-defmacro with-minibuffer-selected-window (&rest body) ;; <compat-tests:with-minibuffer-selected-window> 390 "Execute the forms in BODY from the minibuffer in its original window. 391 When used in a minibuffer window, select the window selected just before 392 the minibuffer was activated, and execute the forms." 393 (declare (indent 0) (debug t)) 394 `(when-let ((window (minibuffer-selected-window))) 395 (with-selected-window window 396 ,@body))) 397 398 ;;;; Defined in byte-run.el 399 400 (compat-defmacro with-suppressed-warnings (_warnings &rest body) ;; <compat-tests:with-suppressed-warnings> 401 "Like `progn', but prevents compiler WARNINGS in BODY. 402 NOTE: The compatibility version behaves like `with-no-warnings'." 403 `(with-no-warnings ,@body)) 404 405 ;;;; Defined in image.el 406 407 (compat-defun image--set-property (image property value) ;; <compat-tests:image-property> 408 "Set PROPERTY in IMAGE to VALUE, internal use only." 409 :extended "26.1" 410 :feature image 411 (if (null value) 412 (while (cdr image) 413 (if (eq (cadr image) property) 414 (setcdr image (cdddr image)) 415 (setq image (cddr image)))) 416 (setcdr image (plist-put (cdr image) property value))) 417 value) 418 419 ;; HACK: image--set-property was broken with an off-by-one error on Emacs 26. 420 ;; The bug was fixed in a4ad7bed187493c1c230f223b52c71f5c34f7c89. Therefore we 421 ;; override the gv expander until Emacs 27.1. 422 (compat-guard ;; <compat-tests:image-property> 423 (or (= emacs-major-version 26) (not (get 'image-property 'gv-expander))) 424 :feature image 425 (gv-define-setter image-property (value image prop) 426 `(,(if (< emacs-major-version 26) 'image--set-property 'compat--image--set-property) 427 ,image ,prop ,value))) 428 429 ;;;; Defined in files.el 430 431 (compat-defun file-name-quoted-p (name &optional top) ;; <compat-tests:file-name-quoted-p> 432 "Handle optional argument TOP." 433 :extended "26.1" 434 (let ((file-name-handler-alist (unless top file-name-handler-alist))) 435 (string-prefix-p "/:" (file-local-name name)))) 436 437 (compat-defun file-name-quote (name &optional top) ;; <compat-tests:file-name-quote> 438 "Handle optional argument TOP." 439 :extended "26.1" 440 (let* ((file-name-handler-alist (unless top file-name-handler-alist)) 441 (localname (file-local-name name))) 442 (if (string-prefix-p "/:" localname) 443 name 444 (concat (file-remote-p name) "/:" localname)))) 445 446 (compat-defun file-name-unquote (name &optional top) ;; <compat-tests:file-name-unquote> 447 "Handle optional argument TOP." 448 :extended "26.1" 449 (let* ((file-name-handler-alist (unless top file-name-handler-alist)) 450 (localname (file-local-name name))) 451 (when (string-prefix-p "/:" localname) 452 (setq localname (if (= (length localname) 2) "/" (substring localname 2)))) 453 (concat (file-remote-p name) localname))) 454 455 (compat-defun file-size-human-readable (file-size &optional flavor space unit) ;; <compat-tests:file-size-human-readable> 456 "Handle the optional arguments SPACE and UNIT." 457 :extended t 458 (let ((power (if (or (null flavor) (eq flavor 'iec)) 459 1024.0 460 1000.0)) 461 (prefixes '("" "k" "M" "G" "T" "P" "E" "Z" "Y"))) 462 (while (and (>= file-size power) (cdr prefixes)) 463 (setq file-size (/ file-size power) 464 prefixes (cdr prefixes))) 465 (let* ((prefix (car prefixes)) 466 (prefixed-unit (if (eq flavor 'iec) 467 (concat 468 (if (string= prefix "k") "K" prefix) 469 (if (string= prefix "") "" "i") 470 (or unit "B")) 471 (concat prefix unit)))) 472 (format (if (and (>= (mod file-size 1.0) 0.05) 473 (< (mod file-size 1.0) 0.95)) 474 "%.1f%s%s" 475 "%.0f%s%s") 476 file-size 477 (if (string= prefixed-unit "") "" (or space "")) 478 prefixed-unit)))) 479 480 (compat-defun file-size-human-readable-iec (size) ;; <compat-tests:file-size-human-readable-iec> 481 "Human-readable string for SIZE bytes, using IEC prefixes." 482 (compat--file-size-human-readable size 'iec " ")) 483 484 (compat-defun exec-path () ;; <compat-tests:exec-path> 485 "Return list of directories to search programs to run in remote subprocesses. 486 The remote host is identified by `default-directory'. For remote 487 hosts that do not support subprocesses, this returns nil. 488 If `default-directory' is a local directory, this function returns 489 the value of the variable `exec-path'." 490 (let ((handler (find-file-name-handler default-directory 'exec-path))) 491 ;; NOTE: The handler may fail since it was added in 27.1. 492 (or (and handler (ignore-errors (funcall handler 'exec-path))) 493 (if (file-remote-p default-directory) 494 ;; FIXME: Just return some standard path on remote 495 '("/bin" "/usr/bin" "/sbin" "/usr/sbin" "/usr/local/bin" "/usr/local/sbin") 496 exec-path)))) 497 498 (compat-defun executable-find (command &optional remote) ;; <compat-tests:executable-find> 499 "Handle optional argument REMOTE." 500 :extended t 501 (if (and remote (file-remote-p default-directory)) 502 (let ((res (locate-file 503 command 504 (mapcar 505 (apply-partially 506 #'concat (file-remote-p default-directory)) 507 (exec-path)) 508 exec-suffixes 'file-executable-p))) 509 (when (stringp res) (file-local-name res))) 510 (executable-find command))) 511 512 (compat-defun make-empty-file (filename &optional parents) ;; <compat-tests:make-empty-file> 513 "Create an empty file FILENAME. 514 Optional arg PARENTS, if non-nil then creates parent dirs as needed." 515 (when (and (file-exists-p filename) (null parents)) 516 (signal 'file-already-exists (list "File exists" filename))) 517 (let ((paren-dir (file-name-directory filename))) 518 (when (and paren-dir (not (file-exists-p paren-dir))) 519 (make-directory paren-dir parents))) 520 (write-region "" nil filename nil 0)) 521 522 ;;;; Defined in regexp-opt.el 523 524 (compat-defun regexp-opt (strings &optional paren) ;; <compat-tests:regexp-opt> 525 "Handle an empty list of STRINGS." 526 :extended t 527 (if (null strings) 528 (let ((re "\\`a\\`")) 529 (cond ((null paren) 530 (concat "\\(?:" re "\\)")) 531 ((stringp paren) 532 (concat paren re "\\)")) 533 ((eq paren 'words) 534 (concat "\\<\\(" re "\\)\\>")) 535 ((eq paren 'symbols) 536 (concat "\\_\\(<" re "\\)\\_>")) 537 ((concat "\\(" re "\\)")))) 538 (regexp-opt strings paren))) 539 540 ;;;; Defined in package.el 541 542 (declare-function lm-header "lisp-mnt") 543 (declare-function macroexp-file-name nil) 544 545 (compat-defun package-get-version () ;; <compat-tests:package-get-version> 546 "Return the version number of the package in which this is used. 547 Assumes it is used from an Elisp file placed inside the top-level directory 548 of an installed ELPA package. 549 The return value is a string (or nil in case we can’t find it)." 550 ;; No :feature since the function is autoloaded. 551 ;; In a sense, this is a lie, but it does just what we want: precompute 552 ;; the version at compile time and hardcodes it into the .elc file! 553 (declare (pure t)) 554 ;; Hack alert! 555 (let ((file (or (macroexp-file-name) buffer-file-name))) 556 (cond 557 ((null file) nil) 558 ;; Packages are normally installed into directories named "<pkg>-<vers>", 559 ;; so get the version number from there. 560 ((string-match 561 "/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'" 562 file) 563 (match-string 1 file)) 564 ;; For packages run straight from the an elpa.git clone, there's no 565 ;; "-<vers>" in the directory name, so we have to fetch the version 566 ;; the hard way. 567 ((let* ((pkgdir (file-name-directory file)) 568 (pkgname (file-name-nondirectory (directory-file-name pkgdir))) 569 (mainfile (expand-file-name (concat pkgname ".el") pkgdir))) 570 (when (file-readable-p mainfile) 571 (require 'lisp-mnt) 572 (with-temp-buffer 573 (insert-file-contents mainfile) 574 (or (lm-header "package-version") 575 (lm-header "version"))))))))) 576 577 ;;;; Defined in time-date.el 578 579 (compat-defun make-decoded-time ;; <compat-tests:make-decoded-time> 580 (&key second minute hour day month year (dst -1) zone) 581 "Return a `decoded-time' structure with only the keywords given filled out." 582 :feature time-date 583 (list second minute hour day month year nil dst zone)) 584 585 (compat-defun date-days-in-month (year month) ;; <compat-tests:date-days-in-month> 586 "The number of days in MONTH in YEAR." 587 :feature time-date 588 (unless (and (numberp month) 589 (<= 1 month) 590 (<= month 12)) 591 (error "Month %s is invalid" month)) 592 (if (= month 2) 593 (if (date-leap-year-p year) 594 29 595 28) 596 (if (memq month '(1 3 5 7 8 10 12)) 597 31 598 30))) 599 600 (compat-defun date-ordinal-to-time (year ordinal) ;; <compat-tests:date-ordinal-to-time> 601 "Convert a YEAR/ORDINAL to the equivalent `decoded-time' structure. 602 ORDINAL is the number of days since the start of the year, with 603 January 1st being 1." 604 (let ((month 1)) 605 (while (> ordinal (date-days-in-month year month)) 606 (setq ordinal (- ordinal (date-days-in-month year month)) 607 month (1+ month))) 608 (list nil nil nil ordinal month year nil nil nil))) 609 610 ;;;; Defined in text-property-search.el 611 612 (declare-function make-prop-match nil) 613 (compat-guard (not (fboundp 'make-prop-match)) ;; <compat-tests:prop-match> 614 (cl-defstruct (prop-match) beginning end value)) 615 616 (compat-defun text-property-search-forward ;; <compat-tests:text-property-search-forward> 617 (property &optional value predicate not-current) 618 "Search for the next region of text where PREDICATE is true. 619 PREDICATE is used to decide whether a value of PROPERTY should be 620 considered as matching VALUE. 621 622 If PREDICATE is a function, it will be called with two arguments: 623 VALUE and the value of PROPERTY. The function should return 624 non-nil if these two values are to be considered a match. 625 626 Two special values of PREDICATE can also be used: 627 If PREDICATE is t, that means a value must `equal' VALUE to be 628 considered a match. 629 If PREDICATE is nil (which is the default value), a value will 630 match if is not `equal' to VALUE. Furthermore, a nil PREDICATE 631 means that the match region is ended if the value changes. For 632 instance, this means that if you loop with 633 634 (while (setq prop (text-property-search-forward \\='face)) 635 ...) 636 637 you will get all distinct regions with non-nil `face' values in 638 the buffer, and the `prop' object will have the details about the 639 match. See the manual for more details and examples about how 640 VALUE and PREDICATE interact. 641 642 If NOT-CURRENT is non-nil, the function will search for the first 643 region that doesn't include point and has a value of PROPERTY 644 that matches VALUE. 645 646 If no matches can be found, return nil and don't move point. 647 If found, move point to the end of the region and return a 648 `prop-match' object describing the match. To access the details 649 of the match, use `prop-match-beginning' and `prop-match-end' for 650 the buffer positions that limit the region, and 651 `prop-match-value' for the value of PROPERTY in the region." 652 (let* ((match-p 653 (lambda (prop-value) 654 (funcall 655 (cond 656 ((eq predicate t) 657 #'equal) 658 ((eq predicate nil) 659 (lambda (val p-val) 660 (not (equal val p-val)))) 661 (predicate)) 662 value prop-value))) 663 (find-end 664 (lambda (start) 665 (let (end) 666 (if (and value 667 (null predicate)) 668 ;; This is the normal case: We're looking for areas where the 669 ;; values aren't, so we aren't interested in sub-areas where the 670 ;; property has different values, all non-matching value. 671 (let ((ended nil)) 672 (while (not ended) 673 (setq end (next-single-property-change (point) property)) 674 (if (not end) 675 (progn 676 (goto-char (point-max)) 677 (setq end (point) 678 ended t)) 679 (goto-char end) 680 (unless (funcall match-p (get-text-property (point) property)) 681 (setq ended t))))) 682 ;; End this at the first place the property changes value. 683 (setq end (next-single-property-change (point) property nil (point-max))) 684 (goto-char end)) 685 (make-prop-match 686 :beginning start 687 :end end 688 :value (get-text-property start property)))))) 689 (cond 690 ;; No matches at the end of the buffer. 691 ((eobp) 692 nil) 693 ;; We're standing in the property we're looking for, so find the 694 ;; end. 695 ((and (funcall match-p (get-text-property (point) property)) 696 (not not-current)) 697 (funcall find-end (point))) 698 (t 699 (let ((origin (point)) 700 (ended nil) 701 pos) 702 ;; Find the next candidate. 703 (while (not ended) 704 (setq pos (next-single-property-change (point) property)) 705 (if (not pos) 706 (progn 707 (goto-char origin) 708 (setq ended t)) 709 (goto-char pos) 710 (if (funcall match-p (get-text-property (point) property)) 711 (setq ended (funcall find-end (point))) 712 ;; Skip past this section of non-matches. 713 (setq pos (next-single-property-change (point) property)) 714 (unless pos 715 (goto-char origin) 716 (setq ended t))))) 717 (and (not (eq ended t)) 718 ended)))))) 719 720 (compat-defun text-property-search-backward ;; <compat-tests:text-property-search-backward> 721 (property &optional value predicate not-current) 722 "Search for the previous region of text whose PROPERTY matches VALUE. 723 724 Like `text-property-search-forward', which see, but searches backward, 725 and if a matching region is found, place point at the start of the region." 726 (let* ((match-p 727 (lambda (prop-value) 728 (funcall 729 (cond 730 ((eq predicate t) 731 #'equal) 732 ((eq predicate nil) 733 (lambda (val p-val) 734 (not (equal val p-val)))) 735 (predicate)) 736 value prop-value))) 737 (find-end 738 (lambda (start) 739 (let (end) 740 (if (and value 741 (null predicate)) 742 ;; This is the normal case: We're looking for areas where the 743 ;; values aren't, so we aren't interested in sub-areas where the 744 ;; property has different values, all non-matching value. 745 (let ((ended nil)) 746 (while (not ended) 747 (setq end (previous-single-property-change (point) property)) 748 (if (not end) 749 (progn 750 (goto-char (point-min)) 751 (setq end (point) 752 ended t)) 753 (goto-char (1- end)) 754 (unless (funcall match-p (get-text-property (point) property)) 755 (goto-char end) 756 (setq ended t))))) 757 ;; End this at the first place the property changes value. 758 (setq end (previous-single-property-change 759 (point) property nil (point-min))) 760 (goto-char end)) 761 (make-prop-match 762 :beginning end 763 :end (1+ start) 764 :value (get-text-property end property)))))) 765 (cond 766 ;; We're at the start of the buffer; no previous matches. 767 ((bobp) 768 nil) 769 ;; We're standing in the property we're looking for, so find the 770 ;; end. 771 ((funcall match-p (get-text-property (1- (point)) property)) 772 (let ((origin (point)) 773 (match (funcall find-end (1- (point)) property value predicate))) 774 ;; When we want to ignore the current element, then repeat the 775 ;; search if we haven't moved out of it yet. 776 (if (and not-current 777 (equal (get-text-property (point) property) 778 (get-text-property origin property))) 779 (text-property-search-backward property value predicate) 780 match))) 781 (t 782 (let ((origin (point)) 783 (ended nil) 784 pos) 785 ;; Find the previous candidate. 786 (while (not ended) 787 (setq pos (previous-single-property-change (point) property)) 788 (if (not pos) 789 (progn 790 (goto-char origin) 791 (setq ended t)) 792 (goto-char (1- pos)) 793 (if (funcall match-p (get-text-property (point) property)) 794 (setq ended 795 (funcall find-end (point))) 796 ;; Skip past this section of non-matches. 797 (setq pos (previous-single-property-change (point) property)) 798 (unless pos 799 (goto-char origin) 800 (setq ended t))))) 801 (and (not (eq ended t)) 802 ended)))))) 803 804 ;;;; Defined in ring.el 805 806 (compat-defun ring-resize (ring size) ;; <compat-tests:ring-resize> 807 "Set the size of RING to SIZE. 808 If the new size is smaller, then the oldest items in the ring are 809 discarded." 810 :feature ring 811 (when (integerp size) 812 (let ((length (ring-length ring)) 813 (new-vec (make-vector size nil))) 814 (if (= length 0) 815 (setcdr ring (cons 0 new-vec)) 816 (let* ((hd (car ring)) 817 (old-size (ring-size ring)) 818 (old-vec (cddr ring)) 819 (copy-length (min size length)) 820 (copy-hd (mod (+ hd (- length copy-length)) length))) 821 (setcdr ring (cons copy-length new-vec)) 822 ;; If the ring is wrapped, the existing elements must be written 823 ;; out in the right order. 824 (dotimes (j copy-length) 825 (aset new-vec j (aref old-vec (mod (+ copy-hd j) old-size)))) 826 (setcar ring 0)))))) 827 828 ;;;; Defined in map-ynp.el 829 830 (compat-version "26.2") 831 832 (compat-defvar read-answer-short 'auto ;; <compat-tests:read-answer> 833 "If non-nil, the `read-answer' function accepts single-character answers. 834 If t, accept short (single key-press) answers to the question. 835 If nil, require long answers. If `auto', accept short answers if 836 `use-short-answers' is non-nil, or the function cell of `yes-or-no-p' 837 is set to `y-or-n-p'. 838 839 Note that this variable does not affect calls to the more 840 commonly-used `yes-or-no-p' function; it only affects calls to 841 the `read-answer' function. To control whether `yes-or-no-p' 842 requires a long or a short answer, see the `use-short-answers' 843 variable.") 844 845 (compat-defun read-answer (question answers) ;; <compat-tests:read-answer> 846 "Read an answer either as a complete word or its character abbreviation. 847 Ask user a question and accept an answer from the list of possible answers. 848 849 QUESTION should end in a space; this function adds a list of answers to it. 850 851 ANSWERS is an alist with elements in the following format: 852 (LONG-ANSWER SHORT-ANSWER HELP-MESSAGE) 853 where 854 LONG-ANSWER is a complete answer, 855 SHORT-ANSWER is an abbreviated one-character answer, 856 HELP-MESSAGE is a string describing the meaning of the answer. 857 858 SHORT-ANSWER is not necessarily a single character answer. It can be 859 also a function key like F1, a character event such as C-M-h, or 860 a control character like C-h. 861 862 Example: 863 \\='((\"yes\" ?y \"perform the action\") 864 (\"no\" ?n \"skip to the next\") 865 (\"all\" ?! \"accept all remaining without more questions\") 866 (\"help\" ?h \"show help\") 867 (\"quit\" ?q \"exit\")) 868 869 When `read-answer-short' is non-nil, accept short answers. 870 871 Return a long answer even in case of accepting short ones. 872 873 When `use-dialog-box' is t, pop up a dialog window to get user input." 874 ;; NOTE: For simplicity we provide a primitive implementation based on 875 ;; `read-multiple-choice', which does neither support long answers nor the the 876 ;; gui dialog box. 877 (cadr (read-multiple-choice 878 (string-trim-right question) 879 (delq nil 880 (mapcar (lambda (x) (unless (equal "help" (car x)) 881 (list (cadr x) (car x) (caddr x)))) 882 answers))))) 883 884 (provide 'compat-27) 885 ;;; compat-27.el ends here