compat-29.el (66491B)
1 ;;; compat-29.el --- Functionality added in Emacs 29.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 ;; Functionality added in Emacs 29.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-28 "28.1") 26 27 ;; Preloaded in loadup.el 28 ;; TODO Update to 29.1 as soon as the Emacs emacs-29 branch version bumped 29 (compat-require seq "29.0") ;; <compat-tests:seq> 30 31 ;; TODO Update to 29.1 as soon as the Emacs emacs-29 branch version bumped 32 (compat-version "29.0") 33 34 ;;;; Defined in xdisp.c 35 36 (compat-defun get-display-property (position prop &optional object properties) ;; <compat-tests:get-display-property> 37 "Get the value of the `display' property PROP at POSITION. 38 If OBJECT, this should be a buffer or string where the property is 39 fetched from. If omitted, OBJECT defaults to the current buffer. 40 41 If PROPERTIES, look for value of PROP in PROPERTIES instead of 42 the properties at POSITION." 43 (if properties 44 (unless (listp properties) 45 (signal 'wrong-type-argument (list 'listp properties))) 46 (setq properties (get-text-property position 'display object))) 47 (cond 48 ((vectorp properties) 49 (catch 'found 50 (dotimes (i (length properties)) 51 (let ((ent (aref properties i))) 52 (when (eq (car ent) prop) 53 (throw 'found (cadr ent ))))))) 54 ((consp (car properties)) 55 (condition-case nil 56 (cadr (assq prop properties)) 57 ;; Silently handle improper lists: 58 (wrong-type-argument nil))) 59 ((and (consp (cdr properties)) 60 (eq (car properties) prop)) 61 (cadr properties)))) 62 63 ;;;; Defined in fns.c 64 65 (compat-defun ntake (n list) ;; <compat-tests:ntake> 66 "Modify LIST to keep only the first N elements. 67 If N is zero or negative, return nil. 68 If N is greater or equal to the length of LIST, return LIST unmodified. 69 Otherwise, return LIST after truncating it." 70 (and (> n 0) (let ((cons (nthcdr (1- n) list))) 71 (when cons (setcdr cons nil)) 72 list))) 73 74 (compat-defun take (n list) ;; <compat-tests:take> 75 "Return the first N elements of LIST. 76 If N is zero or negative, return nil. 77 If N is greater or equal to the length of LIST, return LIST (or a copy)." 78 (declare (pure t) (side-effect-free t)) 79 (let (copy) 80 (while (and (< 0 n) list) 81 (push (pop list) copy) 82 (setq n (1- n))) 83 (nreverse copy))) 84 85 (compat-defun string-equal-ignore-case (string1 string2) ;; <compat-tests:string-equal-ignore-case> 86 "Like `string-equal', but case-insensitive. 87 Upper-case and lower-case letters are treated as equal. 88 Unibyte strings are converted to multibyte for comparison." 89 (declare (pure t) (side-effect-free t)) 90 (eq t (compare-strings string1 0 nil string2 0 nil t))) 91 92 (compat-defun plist-get (plist prop &optional predicate) ;; <compat-tests:plist-get> 93 "Handle optional argument PREDICATE." 94 :extended t 95 (if (or (null predicate) (eq predicate 'eq)) 96 (plist-get plist prop) 97 (catch 'found 98 (while (consp plist) 99 (when (funcall predicate prop (car plist)) 100 (throw 'found (cadr plist))) 101 (setq plist (cddr plist)))))) 102 103 (compat-defun plist-put (plist prop val &optional predicate) ;; <compat-tests:plist-get> 104 "Handle optional argument PREDICATE." 105 :extended t 106 (if (or (null predicate) (eq predicate 'eq)) 107 (plist-put plist prop val) 108 (catch 'found 109 (let ((tail plist)) 110 (while (consp tail) 111 (when (funcall predicate prop (car tail)) 112 (setcar (cdr tail) val) 113 (throw 'found plist)) 114 (setq tail (cddr tail)))) 115 (nconc plist (list prop val))))) 116 117 (compat-defun plist-member (plist prop &optional predicate) ;; <compat-tests:plist-get> 118 "Handle optional argument PREDICATE." 119 :extended t 120 (if (or (null predicate) (eq predicate 'eq)) 121 (plist-member plist prop) 122 (catch 'found 123 (while (consp plist) 124 (when (funcall predicate prop (car plist)) 125 (throw 'found plist)) 126 (setq plist (cddr plist)))))) 127 128 ;;;; Defined in gv.el 129 130 (compat-guard t ;; <compat-tests:plist-get-gv> 131 (gv-define-expander compat--plist-get 132 (lambda (do plist prop &optional predicate) 133 (macroexp-let2 macroexp-copyable-p key prop 134 (gv-letplace (getter setter) plist 135 (macroexp-let2 nil p `(cdr (compat--plist-member ,getter ,key ,predicate)) 136 (funcall do 137 `(car ,p) 138 (lambda (val) 139 `(if ,p 140 (setcar ,p ,val) 141 ,(funcall setter 142 `(cons ,key (cons ,val ,getter))))))))))) 143 (unless (get 'plist-get 'gv-expander) 144 (put 'plist-get 'gv-expander (get 'compat--plist-get 'gv-expander)))) 145 146 ;;;; Defined in editfns.c 147 148 (compat-defun pos-bol (&optional n) ;; <compat-tests:pos-bol> 149 "Return the position of the first character on the current line. 150 With optional argument N, scan forward N - 1 lines first. 151 If the scan reaches the end of the buffer, return that position. 152 153 This function ignores text display directionality; it returns the 154 position of the first character in logical order, i.e. the smallest 155 character position on the logical line. See `vertical-motion' for 156 movement by screen lines. 157 158 This function does not move point. Also see `line-beginning-position'." 159 (declare (side-effect-free t)) 160 (let ((inhibit-field-text-motion t)) 161 (line-beginning-position n))) 162 163 (compat-defun pos-eol (&optional n) ;; <compat-tests:pos-bol> 164 "Return the position of the last character on the current line. 165 With argument N not nil or 1, move forward N - 1 lines first. 166 If scan reaches end of buffer, return that position. 167 168 This function ignores text display directionality; it returns the 169 position of the last character in logical order, i.e. the largest 170 character position on the line. 171 172 This function does not move point. Also see `line-end-position'." 173 (declare (side-effect-free t)) 174 (let ((inhibit-field-text-motion t)) 175 (line-end-position n))) 176 177 ;;;; Defined in subr.el 178 179 (compat-defmacro with-delayed-message (_args &rest body) ;; <compat-tests:with-delayed-message> 180 "Like `progn', but display MESSAGE if BODY takes longer than TIMEOUT seconds. 181 The MESSAGE form will be evaluated immediately, but the resulting 182 string will be displayed only if BODY takes longer than TIMEOUT seconds. 183 184 NOTE: The compatibility function never displays the message, 185 which is not problematic since the only effect of the function is 186 to display a progress message to the user. Backporting this 187 feature is not possible, since the implementation is directly 188 baked into the Elisp interpreter. 189 190 \(fn (timeout message) &rest body)" 191 (declare (indent 1)) 192 (macroexp-progn body)) 193 194 (compat-defun funcall-with-delayed-message (timeout message function) ;; <compat-tests:with-delayed-message> 195 "Like `funcall', but display MESSAGE if FUNCTION takes longer than TIMEOUT. 196 TIMEOUT is a number of seconds, and can be an integer or a 197 floating point number. If FUNCTION takes less time to execute 198 than TIMEOUT seconds, MESSAGE is not displayed. 199 200 NOTE: The compatibility function never displays the message, 201 which is not problematic since the only effect of the function is 202 to display a progress message to the user. Backporting this 203 feature is not possible, since the implementation is directly 204 baked into the Elisp interpreter." 205 (ignore timeout message) 206 (funcall function)) 207 208 (compat-defun string-lines (string &optional omit-nulls keep-newlines) ;; <compat-tests:string-lines> 209 "Handle additional KEEP-NEWLINES argument." 210 :extended "28.1" 211 (if (equal string "") 212 (if omit-nulls 213 nil 214 (list "")) 215 (let ((lines nil) 216 (start 0)) 217 (while (< start (length string)) 218 (let ((newline (string-search "\n" string start))) 219 (if newline 220 (progn 221 (when (or (not omit-nulls) 222 (not (= start newline))) 223 (let ((line (substring string start 224 (if keep-newlines 225 (1+ newline) 226 newline)))) 227 (when (not (and keep-newlines omit-nulls 228 (equal line "\n"))) 229 (push line lines)))) 230 (setq start (1+ newline))) 231 (if (zerop start) 232 (push string lines) 233 (push (substring string start) lines)) 234 (setq start (length string))))) 235 (nreverse lines)))) 236 237 (compat-defun readablep (object) ;; <compat-tests:readablep> 238 "Say whether OBJECT has a readable syntax. 239 This means that OBJECT can be printed out and then read back 240 again by the Lisp reader. This function returns nil if OBJECT is 241 unreadable, and the printed representation (from `prin1') of 242 OBJECT if it is readable." 243 (declare (side-effect-free error-free)) 244 (ignore-errors (equal object (read (prin1-to-string object))))) 245 246 (compat-defun buffer-local-restore-state (states) ;; <compat-tests:buffer-local-set-state> 247 "Restore values of buffer-local variables recorded in STATES. 248 STATES should be an object returned by `buffer-local-set-state'." 249 (dolist (state states) 250 (if (cadr state) 251 (set (car state) (caddr state)) 252 (kill-local-variable (car state))))) 253 254 (compat-defun buffer-local-set-state--get (pairs) ;; <compat-tests:buffer-local-set-state> 255 "Internal helper function." 256 (let ((states nil)) 257 (while pairs 258 (push (list (car pairs) 259 (and (boundp (car pairs)) 260 (local-variable-p (car pairs))) 261 (and (boundp (car pairs)) 262 (symbol-value (car pairs)))) 263 states) 264 (setq pairs (cddr pairs))) 265 (nreverse states))) 266 267 (compat-defmacro buffer-local-set-state (&rest pairs) ;; <compat-tests:buffer-local-set-state> 268 "Like `setq-local', but allow restoring the previous state of locals later. 269 This macro returns an object that can be passed to `buffer-local-restore-state' 270 in order to restore the state of the local variables set via this macro. 271 272 \(fn [VARIABLE VALUE]...)" 273 (declare (debug setq)) 274 (unless (zerop (mod (length pairs) 2)) 275 (error "PAIRS must have an even number of variable/value members")) 276 `(prog1 277 (buffer-local-set-state--get ',pairs) 278 (,(if (fboundp 'compat--setq-local) 'compat--setq-local 'setq-local) 279 ,@pairs))) 280 281 (compat-defun list-of-strings-p (object) ;; <compat-tests:lists-of-strings-p> 282 "Return t if OBJECT is nil or a list of strings." 283 (declare (pure t) (side-effect-free t)) 284 (while (and (consp object) (stringp (car object))) 285 (setq object (cdr object))) 286 (null object)) 287 288 (compat-defun plistp (object) ;; <compat-tests:plistp> 289 "Non-nil if and only if OBJECT is a valid plist." 290 (let ((len (proper-list-p object))) 291 (and len (zerop (% len 2))))) 292 293 (compat-defun delete-line () ;; <compat-tests:delete-line> 294 "Delete the current line." 295 (delete-region (pos-bol) (pos-bol 2))) 296 297 (compat-defmacro with-restriction (start end &rest rest) ;; <compat-tests:with-restriction> 298 "Execute BODY with restrictions set to START and END. 299 300 The current restrictions, if any, are restored upon return. 301 302 When the optional :label LABEL argument is present, in which 303 LABEL is a symbol, inside BODY, `narrow-to-region' and `widen' 304 can be used only within the START and END limits. To gain access 305 to other portions of the buffer, use `without-restriction' with the 306 same LABEL argument. 307 308 \(fn START END [:label LABEL] BODY)" 309 (declare (indent 0) (debug t)) 310 `(save-restriction 311 (narrow-to-region ,start ,end) 312 ;; Locking is ignored 313 ,@(if (eq (car rest) :label) (cddr rest) rest))) 314 315 (compat-defmacro without-restriction (&rest rest) ;; <compat-tests:without-restriction> 316 "Execute BODY without restrictions. 317 318 The current restrictions, if any, are restored upon return. 319 320 When the optional :label LABEL argument is present, the 321 restrictions set by `with-restriction' with the same LABEL argument 322 are lifted. 323 324 \(fn [:label LABEL] BODY)" 325 (declare (indent 0) (debug t)) 326 `(save-restriction 327 (widen) 328 ;; Locking is ignored 329 ,@(if (eq (car rest) :label) (cddr rest) rest))) 330 331 (compat-defmacro with-memoization (place &rest code) ;; <compat-tests:with-memoization> 332 "Return the value of CODE and stash it in PLACE. 333 If PLACE's value is non-nil, then don't bother evaluating CODE 334 and return the value found in PLACE instead." 335 (declare (indent 1)) 336 (gv-letplace (getter setter) place 337 `(or ,getter 338 ,(macroexp-let2 nil val (macroexp-progn code) 339 `(progn 340 ,(funcall setter val) 341 ,val))))) 342 343 (compat-defalias string-split split-string) ;; <compat-tests:string-split> 344 345 (compat-defun compiled-function-p (object) ;; <compat-tests:compiled-function-p> 346 "Return non-nil if OBJECT is a function that has been compiled. 347 Does not distinguish between functions implemented in machine code 348 or byte-code." 349 (or (subrp object) (byte-code-function-p object))) 350 351 (compat-defun function-alias-p (func &optional noerror) ;; <compat-tests:function-alias-p> 352 "Return nil if FUNC is not a function alias. 353 If FUNC is a function alias, return the function alias chain. 354 355 If the function alias chain contains loops, an error will be 356 signalled. If NOERROR, the non-loop parts of the chain is returned." 357 (declare (side-effect-free t)) 358 (let ((chain nil) 359 (orig-func func)) 360 (nreverse 361 (catch 'loop 362 (while (and (symbolp func) 363 (setq func (symbol-function func)) 364 (symbolp func)) 365 (when (or (memq func chain) 366 (eq func orig-func)) 367 (if noerror 368 (throw 'loop chain) 369 (signal 'cyclic-function-indirection (list orig-func)))) 370 (push func chain)) 371 chain)))) 372 373 (compat-defun buffer-match-p (condition buffer-or-name &optional arg) ;; <compat-tests:buffer-match-p> 374 "Return non-nil if BUFFER-OR-NAME matches CONDITION. 375 CONDITION is either: 376 - the symbol t, to always match, 377 - the symbol nil, which never matches, 378 - a regular expression, to match a buffer name, 379 - a predicate function that takes a buffer object and ARG as 380 arguments, and returns non-nil if the buffer matches, 381 - a cons-cell, where the car describes how to interpret the cdr. 382 The car can be one of the following: 383 * `derived-mode': the buffer matches if the buffer's major mode 384 is derived from the major mode in the cons-cell's cdr. 385 * `major-mode': the buffer matches if the buffer's major mode 386 is eq to the cons-cell's cdr. Prefer using `derived-mode' 387 instead when both can work. 388 * `not': the cadr is interpreted as a negation of a condition. 389 * `and': the cdr is a list of recursive conditions, that all have 390 to be met. 391 * `or': the cdr is a list of recursive condition, of which at 392 least one has to be met." 393 (letrec 394 ((buffer (get-buffer buffer-or-name)) 395 (match 396 (lambda (conditions) 397 (catch 'match 398 (dolist (condition conditions) 399 (when (cond 400 ((eq condition t)) 401 ((stringp condition) 402 (string-match-p condition (buffer-name buffer))) 403 ((functionp condition) 404 (condition-case nil 405 (funcall condition buffer) 406 (wrong-number-of-arguments 407 (funcall condition buffer arg)))) 408 ((eq (car-safe condition) 'major-mode) 409 (eq 410 (buffer-local-value 'major-mode buffer) 411 (cdr condition))) 412 ((eq (car-safe condition) 'derived-mode) 413 (provided-mode-derived-p 414 (buffer-local-value 'major-mode buffer) 415 (cdr condition))) 416 ((eq (car-safe condition) 'not) 417 (not (funcall match (cdr condition)))) 418 ((eq (car-safe condition) 'or) 419 (funcall match (cdr condition))) 420 ((eq (car-safe condition) 'and) 421 (catch 'fail 422 (dolist (c (cdr condition)) 423 (unless (funcall match (list c)) 424 (throw 'fail nil))) 425 t))) 426 (throw 'match t))))))) 427 (funcall match (list condition)))) 428 429 (compat-defun match-buffers (condition &optional buffers arg) ;; <compat-tests:match-buffers> 430 "Return a list of buffers that match CONDITION. 431 See `buffer-match' for details on CONDITION. By default all 432 buffers are checked, this can be restricted by passing an 433 optional argument BUFFERS, set to a list of buffers to check. 434 ARG is passed to `buffer-match', for predicate conditions in 435 CONDITION." 436 (let (bufs) 437 (dolist (buf (or buffers (buffer-list))) 438 (when (buffer-match-p condition (get-buffer buf) arg) 439 (push buf bufs))) 440 bufs)) 441 442 (compat-defvar set-transient-map-timeout nil ;; <compat-tests:set-transient-map> 443 "Timeout in seconds for deactivation of a transient keymap. 444 If this is a number, it specifies the amount of idle time 445 after which to deactivate the keymap set by `set-transient-map', 446 thus overriding the value of the TIMEOUT argument to that function.") 447 448 (compat-defvar set-transient-map-timer nil ;; <compat-tests:set-transient-map> 449 "Timer for `set-transient-map-timeout'.") 450 451 (declare-function format-spec "format-spec") 452 (compat-defun set-transient-map (map &optional keep-pred on-exit message timeout) ;; <compat-tests:set-transient-map> 453 "Handle the optional arguments MESSAGE and TIMEOUT." 454 :extended t 455 (unless (fboundp 'format-spec) 456 (require 'format-spec)) 457 (let* ((timeout (or set-transient-map-timeout timeout)) 458 (message 459 (when message 460 (let (keys) 461 (map-keymap (lambda (key cmd) (and cmd (push key keys))) map) 462 (format-spec (if (stringp message) message "Repeat with %k") 463 `((?k . ,(mapconcat 464 (lambda (key) 465 (substitute-command-keys 466 (format "\\`%s'" 467 (key-description (vector key))))) 468 keys ", "))))))) 469 (clearfun (make-symbol "clear-transient-map")) 470 (exitfun 471 (lambda () 472 (internal-pop-keymap map 'overriding-terminal-local-map) 473 (remove-hook 'pre-command-hook clearfun) 474 (when message (message "")) 475 (when set-transient-map-timer (cancel-timer set-transient-map-timer)) 476 (when on-exit (funcall on-exit))))) 477 (fset clearfun 478 (lambda () 479 (with-demoted-errors "set-transient-map PCH: %S" 480 (if (cond 481 ((null keep-pred) nil) 482 ((and (not (eq map (cadr overriding-terminal-local-map))) 483 (memq map (cddr overriding-terminal-local-map))) 484 t) 485 ((eq t keep-pred) 486 (let ((mc (lookup-key map (this-command-keys-vector)))) 487 (when (and mc (symbolp mc)) 488 (setq mc (or (command-remapping mc) mc))) 489 (and mc (eq this-command mc)))) 490 (t (funcall keep-pred))) 491 (when message (message "%s" message)) 492 (funcall exitfun))))) 493 (add-hook 'pre-command-hook clearfun) 494 (internal-push-keymap map 'overriding-terminal-local-map) 495 (when timeout 496 (when set-transient-map-timer (cancel-timer set-transient-map-timer)) 497 (setq set-transient-map-timer (run-with-idle-timer timeout nil exitfun))) 498 (when message (message "%s" message)) 499 exitfun)) 500 501 ;;;; Defined in simple.el 502 503 (compat-defun use-region-noncontiguous-p () ;; <compat-tests:region-noncontiguous-p> 504 "Return non-nil for a non-contiguous region if `use-region-p'." 505 (and (use-region-p) (region-noncontiguous-p))) 506 507 (compat-defun use-region-beginning () ;; <compat-tests:use-region> 508 "Return the start of the region if `use-region-p'." 509 (and (use-region-p) (region-beginning))) 510 511 (compat-defun use-region-end () ;; <compat-tests:use-region> 512 "Return the end of the region if `use-region-p'." 513 (and (use-region-p) (region-end))) 514 515 (compat-defun get-scratch-buffer-create () ;; <compat-tests:get-scratch-buffer-create> 516 "Return the *scratch* buffer, creating a new one if needed." 517 (or (get-buffer "*scratch*") 518 (let ((scratch (get-buffer-create "*scratch*"))) 519 ;; Don't touch the buffer contents or mode unless we know that 520 ;; we just created it. 521 (with-current-buffer scratch 522 (when initial-scratch-message 523 (insert (substitute-command-keys initial-scratch-message)) 524 (set-buffer-modified-p nil)) 525 (funcall initial-major-mode)) 526 scratch))) 527 528 ;;;; Defined in subr-x.el 529 530 (compat-defmacro with-buffer-unmodified-if-unchanged (&rest body) ;; <compat-tests:with-buffer-unmodified-if-unchanged> 531 "Like `progn', but change buffer-modified status only if buffer text changes. 532 If the buffer was unmodified before execution of BODY, and 533 buffer text after execution of BODY is identical to what it was 534 before, ensure that buffer is still marked unmodified afterwards. 535 For example, the following won't change the buffer's modification 536 status: 537 538 (with-buffer-unmodified-if-unchanged 539 (insert \"a\") 540 (delete-char -1)) 541 542 Note that only changes in the raw byte sequence of the buffer text, 543 as stored in the internal representation, are monitored for the 544 purpose of detecting the lack of changes in buffer text. Any other 545 changes that are normally perceived as \"buffer modifications\", such 546 as changes in text properties, `buffer-file-coding-system', buffer 547 multibyteness, etc. -- will not be noticed, and the buffer will still 548 be marked unmodified, effectively ignoring those changes." 549 (declare (debug t) (indent 0)) 550 (let ((hash (gensym)) 551 (buffer (gensym))) 552 `(let ((,hash (and (not (buffer-modified-p)) 553 (buffer-hash))) 554 (,buffer (current-buffer))) 555 (prog1 556 (progn 557 ,@body) 558 ;; If we didn't change anything in the buffer (and the buffer 559 ;; was previously unmodified), then flip the modification status 560 ;; back to "unchanged". 561 (when (and ,hash (buffer-live-p ,buffer)) 562 (with-current-buffer ,buffer 563 (when (and (buffer-modified-p) 564 (equal ,hash (buffer-hash))) 565 (restore-buffer-modified-p nil)))))))) 566 567 (compat-defun add-display-text-property (start end prop value ;; <compat-tests:add-display-text-property> 568 &optional object) 569 "Add display property PROP with VALUE to the text from START to END. 570 If any text in the region has a non-nil `display' property, those 571 properties are retained. 572 573 If OBJECT is non-nil, it should be a string or a buffer. If nil, 574 this defaults to the current buffer." 575 (let ((sub-start start) 576 (sub-end 0) 577 disp) 578 (while (< sub-end end) 579 (setq sub-end (next-single-property-change sub-start 'display object 580 (if (stringp object) 581 (min (length object) end) 582 (min end (point-max))))) 583 (if (not (setq disp (get-text-property sub-start 'display object))) 584 ;; No old properties in this range. 585 (put-text-property sub-start sub-end 'display (list prop value) 586 object) 587 ;; We have old properties. 588 (let ((vector nil)) 589 ;; Make disp into a list. 590 (setq disp 591 (cond 592 ((vectorp disp) 593 (setq vector t) 594 (append disp nil)) 595 ((not (consp (car disp))) 596 (list disp)) 597 (t 598 disp))) 599 ;; Remove any old instances. 600 (when-let ((old (assoc prop disp))) 601 (setq disp (delete old disp))) 602 (setq disp (cons (list prop value) disp)) 603 (when vector 604 (setq disp (vconcat disp))) 605 ;; Finally update the range. 606 (put-text-property sub-start sub-end 'display disp object))) 607 (setq sub-start sub-end)))) 608 609 (compat-defmacro while-let (spec &rest body) ;; <compat-tests:while-let> 610 "Bind variables according to SPEC and conditionally evaluate BODY. 611 Evaluate each binding in turn, stopping if a binding value is nil. 612 If all bindings are non-nil, eval BODY and repeat. 613 614 The variable list SPEC is the same as in `if-let*'." 615 (declare (indent 1) (debug if-let)) 616 (let ((done (gensym "done"))) 617 `(catch ',done 618 (while t 619 (if-let* ,spec 620 (progn 621 ,@body) 622 (throw ',done nil)))))) 623 624 ;;;; Defined in files.el 625 626 (compat-defun directory-abbrev-make-regexp (directory) ;; <compat-tests:directory-abbrev-make-regexp> 627 "Create a regexp to match DIRECTORY for `directory-abbrev-alist'." 628 (let ((regexp 629 ;; We include a slash at the end, to avoid spurious 630 ;; matches such as `/usr/foobar' when the home dir is 631 ;; `/usr/foo'. 632 (concat "\\`" (regexp-quote directory) "\\(/\\|\\'\\)"))) 633 ;; The value of regexp could be multibyte or unibyte. In the 634 ;; latter case, we need to decode it. 635 (if (multibyte-string-p regexp) 636 regexp 637 (decode-coding-string regexp 638 (if (eq system-type 'windows-nt) 639 'utf-8 640 locale-coding-system))))) 641 642 (compat-defun directory-abbrev-apply (filename) ;; <compat-tests:directory-abbrev-apply> 643 "Apply the abbreviations in `directory-abbrev-alist' to FILENAME. 644 Note that when calling this, you should set `case-fold-search' as 645 appropriate for the filesystem used for FILENAME." 646 (dolist (dir-abbrev directory-abbrev-alist filename) 647 (when (string-match (car dir-abbrev) filename) 648 (setq filename (concat (cdr dir-abbrev) 649 (substring filename (match-end 0))))))) 650 651 (compat-defun file-name-split (filename) ;; <compat-tests:file-name-split> 652 "Return a list of all the components of FILENAME. 653 On most systems, this will be true: 654 655 (equal (string-join (file-name-split filename) \"/\") filename)" 656 (let ((components nil)) 657 ;; If this is a directory file name, then we have a null file name 658 ;; at the end. 659 (when (directory-name-p filename) 660 (push "" components) 661 (setq filename (directory-file-name filename))) 662 ;; Loop, chopping off components. 663 (while (length> filename 0) 664 (push (file-name-nondirectory filename) components) 665 (let ((dir (file-name-directory filename))) 666 (setq filename (and dir (directory-file-name dir))) 667 ;; If there's nothing left to peel off, we're at the root and 668 ;; we can stop. 669 (when (and dir (equal dir filename)) 670 (push (if (equal dir "") "" 671 ;; On Windows, the first component might be "c:" or 672 ;; the like. 673 (substring dir 0 -1)) 674 components) 675 (setq filename nil)))) 676 components)) 677 678 (compat-defun file-attribute-file-identifier (attributes) ;; <compat-tests:file-attribute-getters> 679 "The inode and device numbers in ATTRIBUTES returned by `file-attributes'. 680 The value is a list of the form (INODENUM DEVICE), where DEVICE could be 681 either a single number or a cons cell of two numbers. 682 This tuple of numbers uniquely identifies the file." 683 (nthcdr 10 attributes)) 684 685 (compat-defun file-name-parent-directory (filename) ;; <compat-tests:file-name-parent-directory> 686 "Return the directory name of the parent directory of FILENAME. 687 If FILENAME is at the root of the filesystem, return nil. 688 If FILENAME is relative, it is interpreted to be relative 689 to `default-directory', and the result will also be relative." 690 (let* ((expanded-filename (expand-file-name filename)) 691 (parent (file-name-directory (directory-file-name expanded-filename)))) 692 (cond 693 ;; filename is at top-level, therefore no parent 694 ((or (null parent) 695 ;; `equal' is enough, we don't need to resolve symlinks here 696 ;; with `file-equal-p', also for performance 697 (equal parent expanded-filename)) 698 nil) 699 ;; filename is relative, return relative parent 700 ((not (file-name-absolute-p filename)) 701 (file-relative-name parent)) 702 (t 703 parent)))) 704 705 (compat-defvar file-has-changed-p--hash-table ;; <compat-tests:file-has-changed-p> 706 (make-hash-table :test #'equal) 707 "Internal variable used by `file-has-changed-p'.") 708 709 (compat-defun file-has-changed-p (file &optional tag) ;; <compat-tests:file-has-changed-p> 710 "Return non-nil if FILE has changed. 711 The size and modification time of FILE are compared to the size 712 and modification time of the same FILE during a previous 713 invocation of `file-has-changed-p'. Thus, the first invocation 714 of `file-has-changed-p' always returns non-nil when FILE exists. 715 The optional argument TAG, which must be a symbol, can be used to 716 limit the comparison to invocations with identical tags; it can be 717 the symbol of the calling function, for example." 718 (let* ((file (directory-file-name (expand-file-name file))) 719 (remote-file-name-inhibit-cache t) 720 (fileattr (file-attributes file 'integer)) 721 (attr (and fileattr 722 (cons (file-attribute-size fileattr) 723 (file-attribute-modification-time fileattr)))) 724 (sym (concat (symbol-name tag) "@" file)) 725 (cachedattr (gethash sym file-has-changed-p--hash-table))) 726 (unless (equal attr cachedattr) 727 (puthash sym attr file-has-changed-p--hash-table)))) 728 729 ;;;; Defined in keymap.el 730 731 (compat-defun key-valid-p (keys) ;; <compat-tests:key-valid-p> 732 "Say whether KEYS is a valid key. 733 A key is a string consisting of one or more key strokes. 734 The key strokes are separated by single space characters. 735 736 Each key stroke is either a single character, or the name of an 737 event, surrounded by angle brackets. In addition, any key stroke 738 may be preceded by one or more modifier keys. Finally, a limited 739 number of characters have a special shorthand syntax. 740 741 Here's some example key sequences. 742 743 \"f\" (the key `f') 744 \"S o m\" (a three key sequence of the keys `S', `o' and `m') 745 \"C-c o\" (a two key sequence of the keys `c' with the control modifier 746 and then the key `o') 747 \"H-<left>\" (the key named \"left\" with the hyper modifier) 748 \"M-RET\" (the \"return\" key with a meta modifier) 749 \"C-M-<space>\" (the \"space\" key with both the control and meta modifiers) 750 751 These are the characters that have shorthand syntax: 752 NUL, RET, TAB, LFD, ESC, SPC, DEL. 753 754 Modifiers have to be specified in this order: 755 756 A-C-H-M-S-s 757 758 which is 759 760 Alt-Control-Hyper-Meta-Shift-super" 761 (declare (pure t) (side-effect-free t)) 762 (let ((case-fold-search nil)) 763 (and 764 (stringp keys) 765 (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) 766 (save-match-data 767 (catch 'exit 768 (let ((prefixes 769 "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?")) 770 (dolist (key (split-string keys " ")) 771 ;; Every key might have these modifiers, and they should be 772 ;; in this order. 773 (when (string-match (concat "\\`" prefixes) key) 774 (setq key (substring key (match-end 0)))) 775 (unless (or (and (= (length key) 1) 776 ;; Don't accept control characters as keys. 777 (not (< (aref key 0) ?\s)) 778 ;; Don't accept Meta'd characters as keys. 779 (or (multibyte-string-p key) 780 (not (<= 127 (aref key 0) 255)))) 781 (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) 782 ;; Don't allow <M-C-down>. 783 (= (progn 784 (string-match 785 (concat "\\`<" prefixes) key) 786 (match-end 0)) 787 1)) 788 (string-match-p 789 "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" 790 key)) 791 ;; Invalid. 792 (throw 'exit nil))) 793 t)))))) 794 795 (compat-defun keymap--check (key) ;; <compat-tests:keymap--check> 796 "Signal an error if KEY doesn't have a valid syntax." 797 (unless (key-valid-p key) 798 (error "%S is not a valid key definition; see `key-valid-p'" key))) 799 800 (compat-defun key-parse (keys) ;; <compat-tests:key-parse> 801 "Convert KEYS to the internal Emacs key representation. 802 See `kbd' for a descripion of KEYS." 803 (declare (pure t) (side-effect-free t)) 804 ;; A pure function is expected to preserve the match data. 805 (save-match-data 806 (let ((case-fold-search nil) 807 (len (length keys)) ; We won't alter keys in the loop below. 808 (pos 0) 809 (res [])) 810 (while (and (< pos len) 811 (string-match "[^ \t\n\f]+" keys pos)) 812 (let* ((word-beg (match-beginning 0)) 813 (word-end (match-end 0)) 814 (word (substring keys word-beg len)) 815 (times 1) 816 key) 817 ;; Try to catch events of the form "<as df>". 818 (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) 819 (setq word (match-string 0 word) 820 pos (+ word-beg (match-end 0))) 821 (setq word (substring keys word-beg word-end) 822 pos word-end)) 823 (when (string-match "\\([0-9]+\\)\\*." word) 824 (setq times (string-to-number (substring word 0 (match-end 1)))) 825 (setq word (substring word (1+ (match-end 1))))) 826 (cond ((string-match "^<<.+>>$" word) 827 (setq key (vconcat (if (eq (key-binding [?\M-x]) 828 'execute-extended-command) 829 [?\M-x] 830 (or (car (where-is-internal 831 'execute-extended-command)) 832 [?\M-x])) 833 (substring word 2 -2) "\r"))) 834 ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) 835 (progn 836 (setq word (concat (match-string 1 word) 837 (match-string 3 word))) 838 (not (string-match 839 "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" 840 word)))) 841 (setq key (list (intern word)))) 842 ((or (equal word "REM") (string-match "^;;" word)) 843 (setq pos (string-match "$" keys pos))) 844 (t 845 (let ((orig-word word) (prefix 0) (bits 0)) 846 (while (string-match "^[ACHMsS]-." word) 847 (setq bits (+ bits 848 (cdr 849 (assq (aref word 0) 850 '((?A . ?\A-\0) (?C . ?\C-\0) 851 (?H . ?\H-\0) (?M . ?\M-\0) 852 (?s . ?\s-\0) (?S . ?\S-\0)))))) 853 (setq prefix (+ prefix 2)) 854 (setq word (substring word 2))) 855 (when (string-match "^\\^.$" word) 856 (setq bits (+ bits ?\C-\0)) 857 (setq prefix (1+ prefix)) 858 (setq word (substring word 1))) 859 (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") 860 ("LFD" . "\n") ("TAB" . "\t") 861 ("ESC" . "\e") ("SPC" . " ") 862 ("DEL" . "\177"))))) 863 (when found (setq word (cdr found)))) 864 (when (string-match "^\\\\[0-7]+$" word) 865 (let ((n 0)) 866 (dolist (ch (cdr (string-to-list word))) 867 (setq n (+ (* n 8) ch -48))) 868 (setq word (vector n)))) 869 (cond ((= bits 0) 870 (setq key word)) 871 ((and (= bits ?\M-\0) (stringp word) 872 (string-match "^-?[0-9]+$" word)) 873 (setq key (mapcar (lambda (x) (+ x bits)) 874 (append word nil)))) 875 ((/= (length word) 1) 876 (error "%s must prefix a single character, not %s" 877 (substring orig-word 0 prefix) word)) 878 ((and (/= (logand bits ?\C-\0) 0) (stringp word) 879 ;; We used to accept . and ? here, 880 ;; but . is simply wrong, 881 ;; and C-? is not used (we use DEL instead). 882 (string-match "[@-_a-z]" word)) 883 (setq key (list (+ bits (- ?\C-\0) 884 (logand (aref word 0) 31))))) 885 (t 886 (setq key (list (+ bits (aref word 0))))))))) 887 (when key 888 (dolist (_ (number-sequence 1 times)) 889 (setq res (vconcat res key)))))) 890 res))) 891 892 (compat-defun keymap-set (keymap key definition) ;; <compat-tests:defvar-keymap> 893 "Set KEY to DEFINITION in KEYMAP. 894 KEY is a string that satisfies `key-valid-p'. 895 896 DEFINITION is anything that can be a key's definition: 897 nil (means key is undefined in this keymap), 898 a command (a Lisp function suitable for interactive calling), 899 a string (treated as a keyboard macro), 900 a keymap (to define a prefix key), 901 a symbol (when the key is looked up, the symbol will stand for its 902 function definition, which should at that time be one of the above, 903 or another symbol whose function definition is used, etc.), 904 a cons (STRING . DEFN), meaning that DEFN is the definition 905 (DEFN should be a valid definition in its own right) and 906 STRING is the menu item name (which is used only if the containing 907 keymap has been created with a menu name, see `make-keymap'), 908 or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP, 909 or an extended menu item definition. 910 (See info node `(elisp)Extended Menu Items'.)" 911 (keymap--check key) 912 (when (stringp definition) 913 (keymap--check definition) 914 (setq definition (key-parse definition))) 915 (define-key keymap (key-parse key) definition)) 916 917 (compat-defun keymap-unset (keymap key &optional remove) ;; <compat-tests:keymap-unset> 918 "Remove key sequence KEY from KEYMAP. 919 KEY is a string that satisfies `key-valid-p'. 920 921 If REMOVE, remove the binding instead of unsetting it. This only 922 makes a difference when there's a parent keymap. When unsetting 923 a key in a child map, it will still shadow the same key in the 924 parent keymap. Removing the binding will allow the key in the 925 parent keymap to be used." 926 (keymap--check key) 927 (compat--define-key keymap (key-parse key) nil remove)) 928 929 (compat-defun keymap-global-set (key command) ;; <compat-tests:keymap-global-set> 930 "Give KEY a global binding as COMMAND. 931 COMMAND is the command definition to use; usually it is 932 a symbol naming an interactively-callable function. 933 934 KEY is a string that satisfies `key-valid-p'. 935 936 Note that if KEY has a local binding in the current buffer, 937 that local binding will continue to shadow any global binding 938 that you make with this function. 939 940 NOTE: The compatibility version is not a command." 941 (keymap-set (current-global-map) key command)) 942 943 (compat-defun keymap-local-set (key command) ;; <compat-tests:keymap-local-set> 944 "Give KEY a local binding as COMMAND. 945 COMMAND is the command definition to use; usually it is 946 a symbol naming an interactively-callable function. 947 948 KEY is a string that satisfies `key-valid-p'. 949 950 The binding goes in the current buffer's local map, which in most 951 cases is shared with all other buffers in the same major mode. 952 953 NOTE: The compatibility version is not a command." 954 (let ((map (current-local-map))) 955 (unless map 956 (use-local-map (setq map (make-sparse-keymap)))) 957 (keymap-set map key command))) 958 959 (compat-defun keymap-global-unset (key &optional remove) ;; <compat-tests:keymap-global-unset> 960 "Remove global binding of KEY (if any). 961 KEY is a string that satisfies `key-valid-p'. 962 963 If REMOVE (interactively, the prefix arg), remove the binding 964 instead of unsetting it. See `keymap-unset' for details. 965 966 NOTE: The compatibility version is not a command." 967 (keymap-unset (current-global-map) key remove)) 968 969 (compat-defun keymap-local-unset (key &optional remove) ;; <compat-tests:keymap-local-unset> 970 "Remove local binding of KEY (if any). 971 KEY is a string that satisfies `key-valid-p'. 972 973 If REMOVE (interactively, the prefix arg), remove the binding 974 instead of unsetting it. See `keymap-unset' for details. 975 976 NOTE: The compatibility version is not a command." 977 (when (current-local-map) 978 (keymap-unset (current-local-map) key remove))) 979 980 (compat-defun keymap-substitute (keymap olddef newdef &optional oldmap prefix) ;; <compat-tests:keymap-substitute> 981 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. 982 In other words, OLDDEF is replaced with NEWDEF wherever it appears. 983 Alternatively, if optional fourth argument OLDMAP is specified, we redefine 984 in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. 985 986 If you don't specify OLDMAP, you can usually get the same results 987 in a cleaner way with command remapping, like this: 988 (define-key KEYMAP [remap OLDDEF] NEWDEF) 989 \n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" 990 ;; Don't document PREFIX in the doc string because we don't want to 991 ;; advertise it. It's meant for recursive calls only. Here's its 992 ;; meaning 993 994 ;; If optional argument PREFIX is specified, it should be a key 995 ;; prefix, a string. Redefined bindings will then be bound to the 996 ;; original key, with PREFIX added at the front. 997 (unless prefix 998 (setq prefix "")) 999 (let* ((scan (or oldmap keymap)) 1000 (prefix1 (vconcat prefix [nil])) 1001 (key-substitution-in-progress 1002 (cons scan key-substitution-in-progress))) 1003 ;; Scan OLDMAP, finding each char or event-symbol that 1004 ;; has any definition, and act on it with hack-key. 1005 (map-keymap 1006 (lambda (char defn) 1007 (aset prefix1 (length prefix) char) 1008 (substitute-key-definition-key defn olddef newdef prefix1 keymap)) 1009 scan))) 1010 1011 (compat-defun keymap-set-after (keymap key definition &optional after) ;; <compat-tests:keymap-set-after> 1012 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. 1013 This is like `keymap-set' except that the binding for KEY is placed 1014 just after the binding for the event AFTER, instead of at the beginning 1015 of the map. Note that AFTER must be an event type (like KEY), NOT a command 1016 \(like DEFINITION). 1017 1018 If AFTER is t or omitted, the new binding goes at the end of the keymap. 1019 AFTER should be a single event type--a symbol or a character, not a sequence. 1020 1021 Bindings are always added before any inherited map. 1022 1023 The order of bindings in a keymap matters only when it is used as 1024 a menu, so this function is not useful for non-menu keymaps." 1025 (keymap--check key) 1026 (when (eq after t) (setq after nil)) ; nil and t are treated the same 1027 (when (stringp after) 1028 (keymap--check after) 1029 (setq after (key-parse after))) 1030 ;; If we're binding this key to another key, then parse that other 1031 ;; key, too. 1032 (when (stringp definition) 1033 (keymap--check definition) 1034 (setq definition (key-parse definition))) 1035 (define-key-after keymap (key-parse key) definition 1036 after)) 1037 1038 (compat-defun keymap-lookup ;; <compat-tests:keymap-lookup> 1039 (keymap key &optional accept-default no-remap position) 1040 "Return the binding for command KEY. 1041 KEY is a string that satisfies `key-valid-p'. 1042 1043 If KEYMAP is nil, look up in the current keymaps. If non-nil, it 1044 should either be a keymap or a list of keymaps, and only these 1045 keymap(s) will be consulted. 1046 1047 The binding is probably a symbol with a function definition. 1048 1049 Normally, `keymap-lookup' ignores bindings for t, which act as 1050 default bindings, used when nothing else in the keymap applies; 1051 this makes it usable as a general function for probing keymaps. 1052 However, if the optional second argument ACCEPT-DEFAULT is 1053 non-nil, `keymap-lookup' does recognize the default bindings, 1054 just as `read-key-sequence' does. 1055 1056 Like the normal command loop, `keymap-lookup' will remap the 1057 command resulting from looking up KEY by looking up the command 1058 in the current keymaps. However, if the optional third argument 1059 NO-REMAP is non-nil, `keymap-lookup' returns the unmapped 1060 command. 1061 1062 If KEY is a key sequence initiated with the mouse, the used keymaps 1063 will depend on the clicked mouse position with regard to the buffer 1064 and possible local keymaps on strings. 1065 1066 If the optional argument POSITION is non-nil, it specifies a mouse 1067 position as returned by `event-start' and `event-end', and the lookup 1068 occurs in the keymaps associated with it instead of KEY. It can also 1069 be a number or marker, in which case the keymap properties at the 1070 specified buffer position instead of point are used." 1071 (keymap--check key) 1072 (when (and keymap position) 1073 (error "Can't pass in both keymap and position")) 1074 (if keymap 1075 (let ((value (lookup-key keymap (key-parse key) accept-default))) 1076 (if (and (not no-remap) 1077 (symbolp value)) 1078 (or (command-remapping value) value) 1079 value)) 1080 (key-binding (key-parse key) accept-default no-remap position))) 1081 1082 (compat-defun keymap-local-lookup (keys &optional accept-default) ;; <compat-tests:keymap-local-lookup> 1083 "Return the binding for command KEYS in current local keymap only. 1084 KEY is a string that satisfies `key-valid-p'. 1085 1086 The binding is probably a symbol with a function definition. 1087 1088 If optional argument ACCEPT-DEFAULT is non-nil, recognize default 1089 bindings; see the description of `keymap-lookup' for more details 1090 about this." 1091 (when-let ((map (current-local-map))) 1092 (keymap-lookup map keys accept-default))) 1093 1094 (compat-defun keymap-global-lookup (keys &optional accept-default _message) ;; <compat-tests:keymap-global-lookup> 1095 "Return the binding for command KEYS in current global keymap only. 1096 KEY is a string that satisfies `key-valid-p'. 1097 1098 The binding is probably a symbol with a function definition. 1099 This function's return values are the same as those of `keymap-lookup' 1100 \(which see). 1101 1102 If optional argument ACCEPT-DEFAULT is non-nil, recognize default 1103 bindings; see the description of `keymap-lookup' for more details 1104 about this. 1105 1106 NOTE: The compatibility version is not a command." 1107 (keymap-lookup (current-global-map) keys accept-default)) 1108 1109 (compat-defun define-keymap (&rest definitions) ;; <compat-tests:defvar-keymap> 1110 "Create a new keymap and define KEY/DEFINITION pairs as key bindings. 1111 The new keymap is returned. 1112 1113 Options can be given as keywords before the KEY/DEFINITION 1114 pairs. Available keywords are: 1115 1116 :full If non-nil, create a chartable alist (see `make-keymap'). 1117 If nil (i.e., the default), create a sparse keymap (see 1118 `make-sparse-keymap'). 1119 1120 :suppress If non-nil, the keymap will be suppressed (see `suppress-keymap'). 1121 If `nodigits', treat digits like other chars. 1122 1123 :parent If non-nil, this should be a keymap to use as the parent 1124 (see `set-keymap-parent'). 1125 1126 :keymap If non-nil, instead of creating a new keymap, the given keymap 1127 will be destructively modified instead. 1128 1129 :name If non-nil, this should be a string to use as the menu for 1130 the keymap in case you use it as a menu with `x-popup-menu'. 1131 1132 :prefix If non-nil, this should be a symbol to be used as a prefix 1133 command (see `define-prefix-command'). If this is the case, 1134 this symbol is returned instead of the map itself. 1135 1136 KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can 1137 also be the special symbol `:menu', in which case DEFINITION 1138 should be a MENU form as accepted by `easy-menu-define'. 1139 1140 \(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" 1141 (declare (indent defun)) 1142 (let (full suppress parent name prefix keymap) 1143 ;; Handle keywords. 1144 (while (and definitions 1145 (keywordp (car definitions)) 1146 (not (eq (car definitions) :menu))) 1147 (let ((keyword (pop definitions))) 1148 (unless definitions 1149 (error "Missing keyword value for %s" keyword)) 1150 (let ((value (pop definitions))) 1151 (pcase keyword 1152 (:full (setq full value)) 1153 (:keymap (setq keymap value)) 1154 (:parent (setq parent value)) 1155 (:suppress (setq suppress value)) 1156 (:name (setq name value)) 1157 (:prefix (setq prefix value)) 1158 (_ (error "Invalid keyword: %s" keyword)))))) 1159 1160 (when (and prefix 1161 (or full parent suppress keymap)) 1162 (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords")) 1163 1164 (when (and keymap full) 1165 (error "Invalid combination: :keymap with :full")) 1166 1167 (let ((keymap (cond 1168 (keymap keymap) 1169 (prefix (define-prefix-command prefix nil name)) 1170 (full (make-keymap name)) 1171 (t (make-sparse-keymap name)))) 1172 seen-keys) 1173 (when suppress 1174 (suppress-keymap keymap (eq suppress 'nodigits))) 1175 (when parent 1176 (set-keymap-parent keymap parent)) 1177 1178 ;; Do the bindings. 1179 (while definitions 1180 (let ((key (pop definitions))) 1181 (unless definitions 1182 (error "Uneven number of key/definition pairs")) 1183 (let ((def (pop definitions))) 1184 (if (eq key :menu) 1185 (easy-menu-define nil keymap "" def) 1186 (if (member key seen-keys) 1187 (error "Duplicate definition for key: %S %s" key keymap) 1188 (push key seen-keys)) 1189 (keymap-set keymap key def))))) 1190 keymap))) 1191 1192 (compat-defmacro defvar-keymap (variable-name &rest defs) ;; <compat-tests:defvar-keymap> 1193 "Define VARIABLE-NAME as a variable with a keymap definition. 1194 See `define-keymap' for an explanation of the keywords and KEY/DEFINITION. 1195 1196 In addition to the keywords accepted by `define-keymap', this 1197 macro also accepts a `:doc' keyword, which (if present) is used 1198 as the variable documentation string. 1199 1200 The `:repeat' keyword can also be specified; it controls the 1201 `repeat-mode' behavior of the bindings in the keymap. When it is 1202 non-nil, all commands in the map will have the `repeat-map' 1203 symbol property. 1204 1205 More control is available over which commands are repeatable; the 1206 value can also be a property list with properties `:enter' and 1207 `:exit', for example: 1208 1209 :repeat (:enter (commands ...) :exit (commands ...)) 1210 1211 `:enter' specifies the list of additional commands that only 1212 enter `repeat-mode'. When the list is empty, then only the 1213 commands defined in the map enter `repeat-mode'. Specifying a 1214 list of commands is useful when there are commands that have the 1215 `repeat-map' symbol property, but don't exist in this specific 1216 map. 1217 1218 `:exit' is a list of commands that exit `repeat-mode'. When the 1219 list is empty, no commands in the map exit `repeat-mode'. 1220 Specifying a list of commands is useful when those commands exist 1221 in this specific map, but should not have the `repeat-map' symbol 1222 property. 1223 1224 \(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP REPEAT &rest [KEY DEFINITION]...)" 1225 (declare (indent 1)) 1226 (let ((opts nil) 1227 doc repeat props) 1228 (while (and defs 1229 (keywordp (car defs)) 1230 (not (eq (car defs) :menu))) 1231 (let ((keyword (pop defs))) 1232 (unless defs 1233 (error "Uneven number of keywords")) 1234 (cond 1235 ((eq keyword :doc) (setq doc (pop defs))) 1236 ((eq keyword :repeat) (setq repeat (pop defs))) 1237 (t (push keyword opts) 1238 (push (pop defs) opts))))) 1239 (unless (zerop (% (length defs) 2)) 1240 (error "Uneven number of key/definition pairs: %s" defs)) 1241 1242 (let ((defs defs) 1243 key seen-keys) 1244 (while defs 1245 (setq key (pop defs)) 1246 (pop defs) 1247 (unless (eq key :menu) 1248 (if (member key seen-keys) 1249 (error "Duplicate definition for key '%s' in keymap '%s'" 1250 key variable-name) 1251 (push key seen-keys))))) 1252 1253 (when repeat 1254 (let ((defs defs) 1255 def) 1256 (dolist (def (plist-get repeat :enter)) 1257 (push `(put ',def 'repeat-map ',variable-name) props)) 1258 (while defs 1259 (pop defs) 1260 (setq def (pop defs)) 1261 (when (and (memq (car def) '(function quote)) 1262 (not (memq (cadr def) (plist-get repeat :exit)))) 1263 (push `(put ,def 'repeat-map ',variable-name) props))))) 1264 1265 (let ((defvar-form 1266 `(defvar ,variable-name 1267 (define-keymap ,@(nreverse opts) ,@defs) 1268 ,@(and doc (list doc))))) 1269 (if props 1270 `(progn 1271 ,defvar-form 1272 ,@(nreverse props)) 1273 defvar-form)))) 1274 1275 ;;;; Defined in keymap.c 1276 1277 (compat-defun define-key (keymap key def &optional remove) ;; <compat-tests:define-key> 1278 "Handle optional argument REMOVE." 1279 :extended t 1280 (if (not remove) 1281 (define-key keymap key def) 1282 ;; Canonicalize key 1283 (setq key (key-parse (key-description key))) 1284 (define-key keymap key nil) 1285 ;; Split M-key in ESC key 1286 (setq key (mapcan (lambda (k) 1287 (if (and (integerp k) (/= (logand k ?\M-\0) 0)) 1288 (list ?\e (logxor k ?\M-\0)) 1289 (list k))) 1290 key)) 1291 ;; Delete single keys directly 1292 (if (length= key 1) 1293 (delete key keymap) 1294 ;; Lookup submap and delete key from there 1295 (let ((submap (lookup-key keymap (vconcat (butlast key))))) 1296 (unless (keymapp submap) 1297 (error "Not a keymap for %s" key)) 1298 (when (symbolp submap) 1299 (setq submap (symbol-function submap))) 1300 (delete (last key) submap))) 1301 def)) 1302 1303 ;;;; Defined in help.el 1304 1305 (compat-defun substitute-quotes (string) ;; <compat-tests:substitute-quotes> 1306 "Substitute quote characters for display. 1307 Each grave accent \\=` is replaced by left quote, and each 1308 apostrophe \\=' is replaced by right quote. Left and right quote 1309 characters are specified by `text-quoting-style'." 1310 (cond ((eq (text-quoting-style) 'curve) 1311 (string-replace "`" "‘" 1312 (string-replace "'" "’" string))) 1313 ((eq (text-quoting-style) 'straight) 1314 (string-replace "`" "'" string)) 1315 (t string))) 1316 1317 ;;;; Defined in button.el 1318 1319 (compat-defun button--properties (callback data help-echo) ;; <compat-tests:buttonize> 1320 "Helper function." 1321 (list 'font-lock-face 'button 1322 'mouse-face 'highlight 1323 'help-echo help-echo 1324 'button t 1325 'follow-link t 1326 'category t 1327 'button-data data 1328 'keymap button-map 1329 'action callback)) 1330 1331 (compat-defun buttonize (string callback &optional data help-echo) ;; <compat-tests:buttonize> 1332 "Make STRING into a button and return it. 1333 When clicked, CALLBACK will be called with the DATA as the 1334 function argument. If DATA isn't present (or is nil), the button 1335 itself will be used instead as the function argument. 1336 1337 If HELP-ECHO, use that as the `help-echo' property. 1338 1339 Also see `buttonize-region'." 1340 (let ((string 1341 (apply #'propertize string 1342 (button--properties callback data help-echo)))) 1343 ;; Add the face to the end so that it can be overridden. 1344 (add-face-text-property 0 (length string) 'button t string) 1345 string)) 1346 1347 (compat-defun buttonize-region (start end callback &optional data help-echo) ;; <compat-tests:buttonize-region> 1348 "Make the region between START and END into a button. 1349 When clicked, CALLBACK will be called with the DATA as the 1350 function argument. If DATA isn't present (or is nil), the button 1351 itself will be used instead as the function argument. 1352 1353 If HELP-ECHO, use that as the `help-echo' property. 1354 1355 Also see `buttonize'." 1356 (add-text-properties start end (button--properties callback data help-echo)) 1357 (add-face-text-property start end 'button t)) 1358 1359 ;;;; Defined in rmc.el 1360 1361 (compat-defun read-multiple-choice ;; <compat-tests:read-multiple-choice> 1362 (prompt choices &optional _help-str _show-help long-form) 1363 "Handle LONG-FORM argument." 1364 :extended t 1365 (if (not long-form) 1366 (read-multiple-choice prompt choices) 1367 (let ((answer 1368 (completing-read 1369 (concat prompt " (" 1370 (mapconcat #'identity (mapcar #'cadr choices) "/") 1371 ") ") 1372 (mapcar #'cadr choices) nil t))) 1373 (catch 'found 1374 (dolist (c choices) 1375 (when (equal answer (cadr c)) 1376 (throw 'found c))))))) 1377 1378 ;;;; Defined in paragraphs.el 1379 1380 (compat-defun count-sentences (start end) ;; <compat-tests:count-sentences> 1381 "Count sentences in current buffer from START to END." 1382 (let ((sentences 0) 1383 (inhibit-field-text-motion t)) 1384 (save-excursion 1385 (save-restriction 1386 (narrow-to-region start end) 1387 (goto-char (point-min)) 1388 (while (ignore-errors (forward-sentence)) 1389 (setq sentences (1+ sentences))) 1390 (when (/= (skip-chars-backward " \t\n") 0) 1391 (setq sentences (1- sentences))) 1392 sentences)))) 1393 1394 ;;;; Defined in cl-lib.el 1395 1396 (compat-defun cl-constantly (value) ;; <compat-tests:cl-constantly> 1397 "Return a function that takes any number of arguments, but returns VALUE." 1398 :feature cl-lib 1399 (lambda (&rest _) value)) 1400 1401 ;;;; Defined in cl-macs.el 1402 1403 (compat-defmacro cl-with-gensyms (names &rest body) ;; <compat-tests:cl-with-gensyms> 1404 "Bind each of NAMES to an uninterned symbol and evaluate BODY." 1405 ;; No :feature since macro is autoloaded 1406 (declare (debug (sexp body)) (indent 1)) 1407 `(let ,(cl-loop for name in names collect 1408 `(,name (gensym (symbol-name ',name)))) 1409 ,@body)) 1410 1411 (compat-defmacro cl-once-only (names &rest body) ;; <compat-tests:cl-once-only> 1412 "Generate code to evaluate each of NAMES just once in BODY. 1413 1414 This macro helps with writing other macros. Each of names is 1415 either (NAME FORM) or NAME, which latter means (NAME NAME). 1416 During macroexpansion, each NAME is bound to an uninterned 1417 symbol. The expansion evaluates each FORM and binds it to the 1418 corresponding uninterned symbol. 1419 1420 For example, consider this macro: 1421 1422 (defmacro my-cons (x) 1423 (cl-once-only (x) 1424 \\=`(cons ,x ,x))) 1425 1426 The call (my-cons (pop y)) will expand to something like this: 1427 1428 (let ((g1 (pop y))) 1429 (cons g1 g1)) 1430 1431 The use of `cl-once-only' ensures that the pop is performed only 1432 once, as intended. 1433 1434 See also `macroexp-let2'." 1435 ;; No :feature since macro is autoloaded 1436 (declare (debug (sexp body)) (indent 1)) 1437 (setq names (mapcar #'ensure-list names)) 1438 (let ((our-gensyms (cl-loop for _ in names collect (gensym)))) 1439 `(let ,(cl-loop for sym in our-gensyms collect `(,sym (gensym))) 1440 `(let ,(list 1441 ,@(cl-loop for name in names for gensym in our-gensyms 1442 for to-eval = (or (cadr name) (car name)) 1443 collect ``(,,gensym ,,to-eval))) 1444 ,(let ,(cl-loop for name in names for gensym in our-gensyms 1445 collect `(,(car name) ,gensym)) 1446 ,@body))))) 1447 1448 ;;;; Defined in ert-x.el 1449 1450 (compat-defmacro ert-with-temp-file (name &rest body) ;; <compat-tests:ert-with-temp-file> 1451 "Bind NAME to the name of a new temporary file and evaluate BODY. 1452 Delete the temporary file after BODY exits normally or 1453 non-locally. NAME will be bound to the file name of the temporary 1454 file. 1455 1456 The following keyword arguments are supported: 1457 1458 :prefix STRING If non-nil, pass STRING to `make-temp-file' as 1459 the PREFIX argument. Otherwise, use the value of 1460 `ert-temp-file-prefix'. 1461 1462 :suffix STRING If non-nil, pass STRING to `make-temp-file' as the 1463 SUFFIX argument. Otherwise, use the value of 1464 `ert-temp-file-suffix'; if the value of that 1465 variable is nil, generate a suffix based on the 1466 name of the file that `ert-with-temp-file' is 1467 called from. 1468 1469 :text STRING If non-nil, pass STRING to `make-temp-file' as 1470 the TEXT argument. 1471 1472 :buffer SYMBOL Open the temporary file using `find-file-noselect' 1473 and bind SYMBOL to the buffer. Kill the buffer 1474 after BODY exits normally or non-locally. 1475 1476 :coding CODING If non-nil, bind `coding-system-for-write' to CODING 1477 when executing BODY. This is handy when STRING includes 1478 non-ASCII characters or the temporary file must have a 1479 specific encoding or end-of-line format. 1480 1481 See also `ert-with-temp-directory'." 1482 :feature ert-x 1483 (declare (indent 1) (debug (symbolp body))) 1484 (cl-check-type name symbol) 1485 (let (keyw prefix suffix directory text extra-keywords buffer coding) 1486 (while (keywordp (setq keyw (car body))) 1487 (setq body (cdr body)) 1488 (pcase keyw 1489 (:prefix (setq prefix (pop body))) 1490 (:suffix (setq suffix (pop body))) 1491 ;; This is only for internal use by `ert-with-temp-directory' 1492 ;; and is therefore not documented. 1493 (:directory (setq directory (pop body))) 1494 (:text (setq text (pop body))) 1495 (:buffer (setq buffer (pop body))) 1496 (:coding (setq coding (pop body))) 1497 (_ (push keyw extra-keywords) (pop body)))) 1498 (when extra-keywords 1499 (error "Invalid keywords: %s" (mapconcat #'symbol-name extra-keywords " "))) 1500 (let ((temp-file (make-symbol "temp-file")) 1501 (prefix (or prefix "emacs-test-")) 1502 (suffix (or suffix 1503 (thread-last 1504 (file-name-base (or (macroexp-file-name) buffer-file-name)) 1505 (replace-regexp-in-string (rx string-start 1506 (group (+? not-newline)) 1507 (regexp "-?tests?") 1508 string-end) 1509 "\\1") 1510 (concat "-"))))) 1511 `(let* ((coding-system-for-write ,(or coding coding-system-for-write)) 1512 (,temp-file (,(if directory 'file-name-as-directory 'identity) 1513 (,(if (fboundp 'compat--make-temp-file) 1514 'compat--make-temp-file 'make-temp-file) 1515 ,prefix ,directory ,suffix ,text))) 1516 (,name ,(if directory 1517 `(file-name-as-directory ,temp-file) 1518 temp-file)) 1519 ,@(when buffer 1520 (list `(,buffer (find-file-literally ,temp-file))))) 1521 (unwind-protect 1522 (progn ,@body) 1523 (ignore-errors 1524 ,@(when buffer 1525 (list `(with-current-buffer ,buffer 1526 (set-buffer-modified-p nil)) 1527 `(kill-buffer ,buffer)))) 1528 (ignore-errors 1529 ,(if directory 1530 `(delete-directory ,temp-file :recursive) 1531 `(delete-file ,temp-file)))))))) 1532 1533 (compat-defmacro ert-with-temp-directory (name &rest body) ;; <compat-tests:ert-with-temp-directory> 1534 "Bind NAME to the name of a new temporary directory and evaluate BODY. 1535 Delete the temporary directory after BODY exits normally or 1536 non-locally. 1537 1538 NAME is bound to the directory name, not the directory file 1539 name. (In other words, it will end with the directory delimiter; 1540 on Unix-like systems, it will end with \"/\".) 1541 1542 The same keyword arguments are supported as in 1543 `ert-with-temp-file' (which see), except for :text." 1544 :feature ert-x 1545 (declare (indent 1) (debug (symbolp body))) 1546 (let ((tail body) keyw) 1547 (while (keywordp (setq keyw (car tail))) 1548 (setq tail (cddr tail)) 1549 (pcase keyw (:text (error "Invalid keyword for directory: :text"))))) 1550 `(ert-with-temp-file ,name 1551 :directory t 1552 ,@body)) 1553 1554 ;;;; Defined in wid-edit.el 1555 1556 (compat-guard (not (fboundp 'widget-key-validate)) ;; <compat-tests:widget-key> 1557 :feature wid-edit 1558 (defvar widget-key-prompt-value-history nil 1559 "History of input to `widget-key-prompt-value'.") 1560 (define-widget 'key 'editable-field 1561 "A key sequence." 1562 :prompt-value 'widget-field-prompt-value 1563 :match 'widget-key-valid-p 1564 :format "%{%t%}: %v" 1565 :validate 'widget-key-validate 1566 :keymap widget-key-sequence-map 1567 :help-echo "C-q: insert KEY, EVENT, or CODE; RET: enter value" 1568 :tag "Key") 1569 (defun widget-key-valid-p (_widget value) 1570 (key-valid-p value)) 1571 (defun widget-key-validate (widget) 1572 (unless (and (stringp (widget-value widget)) 1573 (key-valid-p (widget-value widget))) 1574 (widget-put widget :error (format "Invalid key: %S" 1575 (widget-value widget))) 1576 widget))) 1577 1578 (provide 'compat-29) 1579 ;;; compat-29.el ends here