compat-29.el (41714B)
1 ;;; compat-29.el --- Compatibility Layer for 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 ;; Find here the functionality added in Emacs 29.1, needed by older 21 ;; versions. 22 23 ;;; Code: 24 25 (eval-when-compile (load "compat-macs.el" nil t t)) 26 ;; TODO Update to 29.1 as soon as the Emacs emacs-29 branch version bumped 27 (compat-declare-version "29.0") 28 29 ;;;; Defined in xdisp.c 30 31 (compat-defun get-display-property (position prop &optional object properties) ;; <OK> 32 "Get the value of the `display' property PROP at POSITION. 33 If OBJECT, this should be a buffer or string where the property is 34 fetched from. If omitted, OBJECT defaults to the current buffer. 35 36 If PROPERTIES, look for value of PROP in PROPERTIES instead of 37 the properties at POSITION." 38 (if properties 39 (unless (listp properties) 40 (signal 'wrong-type-argument (list 'listp properties))) 41 (setq properties (get-text-property position 'display object))) 42 (cond 43 ((vectorp properties) 44 (catch 'found 45 (dotimes (i (length properties)) 46 (let ((ent (aref properties i))) 47 (when (eq (car ent) prop) 48 (throw 'found (cadr ent ))))))) 49 ((consp (car properties)) 50 (condition-case nil 51 (cadr (assq prop properties)) 52 ;; Silently handle improper lists: 53 (wrong-type-argument nil))) 54 ((and (consp (cdr properties)) 55 (eq (car properties) prop)) 56 (cadr properties)))) 57 58 ;;;; Defined in fns.c 59 60 (compat-defun ntake (n list) ;; <OK> 61 "Modify LIST to keep only the first N elements. 62 If N is zero or negative, return nil. 63 If N is greater or equal to the length of LIST, return LIST unmodified. 64 Otherwise, return LIST after truncating it." 65 (and (> n 0) (let ((cons (nthcdr (1- n) list))) 66 (when cons (setcdr cons nil)) 67 list))) 68 69 (compat-defun take (n list) ;; <OK> 70 "Return the first N elements of LIST. 71 If N is zero or negative, return nil. 72 If N is greater or equal to the length of LIST, return LIST (or a copy)." 73 (declare (pure t) (side-effect-free t)) 74 (let (copy) 75 (while (and (< 0 n) list) 76 (push (pop list) copy) 77 (setq n (1- n))) 78 (nreverse copy))) 79 80 (compat-defun string-equal-ignore-case (string1 string2) ;; <OK> 81 "Like `string-equal', but case-insensitive. 82 Upper-case and lower-case letters are treated as equal. 83 Unibyte strings are converted to multibyte for comparison." 84 (declare (pure t) (side-effect-free t)) 85 (eq t (compare-strings string1 0 nil string2 0 nil t))) 86 87 (compat-defun plist-get (plist prop &optional predicate) ;; <OK> 88 "Handle optional argument PREDICATE." 89 :explicit t 90 (if (or (null predicate) (eq predicate 'eq)) 91 (plist-get plist prop) 92 (catch 'found 93 (while (consp plist) 94 (when (funcall predicate prop (car plist)) 95 (throw 'found (cadr plist))) 96 (setq plist (cddr plist)))))) 97 98 (compat-defun plist-put (plist prop val &optional predicate) ;; <OK> 99 "Handle optional argument PREDICATE." 100 :explicit t 101 (if (or (null predicate) (eq predicate 'eq)) 102 (plist-put plist prop val) 103 (catch 'found 104 (let ((tail plist)) 105 (while (consp tail) 106 (when (funcall predicate prop (car tail)) 107 (setcar (cdr tail) val) 108 (throw 'found plist)) 109 (setq tail (cddr tail)))) 110 (nconc plist (list prop val))))) 111 112 (compat-defun plist-member (plist prop &optional predicate) ;; <OK> 113 "Handle optional argument PREDICATE." 114 :explicit t 115 (if (or (null predicate) (eq predicate 'eq)) 116 (plist-member plist prop) 117 (catch 'found 118 (while (consp plist) 119 (when (funcall predicate prop (car plist)) 120 (throw 'found plist)) 121 (setq plist (cddr plist)))))) 122 123 ;;;; Defined in editfns.c 124 125 (compat-defun pos-bol (&optional n) ;; <OK> 126 "Return the position of the first character on the current line. 127 With optional argument N, scan forward N - 1 lines first. 128 If the scan reaches the end of the buffer, return that position. 129 130 This function ignores text display directionality; it returns the 131 position of the first character in logical order, i.e. the smallest 132 character position on the logical line. See `vertical-motion' for 133 movement by screen lines. 134 135 This function does not move point. Also see `line-beginning-position'." 136 (declare (side-effect-free t)) 137 (let ((inhibit-field-text-motion t)) 138 (line-beginning-position n))) 139 140 (compat-defun pos-eol (&optional n) ;; <OK> 141 "Return the position of the last character on the current line. 142 With argument N not nil or 1, move forward N - 1 lines first. 143 If scan reaches end of buffer, return that position. 144 145 This function ignores text display directionality; it returns the 146 position of the last character in logical order, i.e. the largest 147 character position on the line. 148 149 This function does not move point. Also see `line-end-position'." 150 (declare (side-effect-free t)) 151 (let ((inhibit-field-text-motion t)) 152 (line-end-position n))) 153 154 ;;;; Defined in keymap.c 155 156 (compat-defun define-key (keymap key def &optional remove) ;; <UNTESTED> 157 "Handle optional argument REMOVE." 158 :explicit t 159 (if remove 160 (let ((prev (lookup-key keymap key)) 161 (parent (memq 'key (cdr keymap))) 162 fresh entry) 163 (when prev 164 ;; IMPROVEME: Kind of a hack to avoid relying on the specific 165 ;; behaviour of how `define-key' changes KEY before inserting 166 ;; it into the map. 167 (define-key keymap key (setq fresh (make-symbol "fresh"))) 168 (setq entry (rassq fresh (cdr keymap))) 169 (if (> (length (memq entry (cdr keymap))) 170 (length parent)) 171 ;; Ensure that we only remove an element in the current 172 ;; keymap and not a parent, by ensuring that `entry' is 173 ;; located before `parent'. 174 (ignore (setcdr keymap (delq entry (cdr keymap)))) 175 (define-key keymap key prev)))) 176 (define-key keymap key def))) 177 178 ;;;; Defined in subr.el 179 180 (compat-defmacro with-memoization (place &rest code) ;; <OK> 181 "Return the value of CODE and stash it in PLACE. 182 If PLACE's value is non-nil, then don't bother evaluating CODE 183 and return the value found in PLACE instead." 184 (declare (indent 1)) 185 (gv-letplace (getter setter) place 186 `(or ,getter 187 ,(macroexp-let2 nil val (macroexp-progn code) 188 `(progn 189 ,(funcall setter val) 190 ,val))))) 191 192 (compat-defalias string-split split-string) ;; <OK> 193 194 (compat-defun function-alias-p (func &optional noerror) ;; <OK> 195 "Return nil if FUNC is not a function alias. 196 If FUNC is a function alias, return the function alias chain. 197 198 If the function alias chain contains loops, an error will be 199 signalled. If NOERROR, the non-loop parts of the chain is returned." 200 (declare (side-effect-free t)) 201 (let ((chain nil) 202 (orig-func func)) 203 (nreverse 204 (catch 'loop 205 (while (and (symbolp func) 206 (setq func (symbol-function func)) 207 (symbolp func)) 208 (when (or (memq func chain) 209 (eq func orig-func)) 210 (if noerror 211 (throw 'loop chain) 212 (signal 'cyclic-function-indirection (list orig-func)))) 213 (push func chain)) 214 chain)))) 215 216 (compat-defun buffer-match-p (condition buffer-or-name &optional arg) ;; <UNTESTED> 217 "Return non-nil if BUFFER-OR-NAME matches CONDITION. 218 CONDITION is either: 219 - the symbol t, to always match, 220 - the symbol nil, which never matches, 221 - a regular expression, to match a buffer name, 222 - a predicate function that takes a buffer object and ARG as 223 arguments, and returns non-nil if the buffer matches, 224 - a cons-cell, where the car describes how to interpret the cdr. 225 The car can be one of the following: 226 * `derived-mode': the buffer matches if the buffer's major mode 227 is derived from the major mode in the cons-cell's cdr. 228 * `major-mode': the buffer matches if the buffer's major mode 229 is eq to the cons-cell's cdr. Prefer using `derived-mode' 230 instead when both can work. 231 * `not': the cadr is interpreted as a negation of a condition. 232 * `and': the cdr is a list of recursive conditions, that all have 233 to be met. 234 * `or': the cdr is a list of recursive condition, of which at 235 least one has to be met." 236 (letrec 237 ((buffer (get-buffer buffer-or-name)) 238 (match 239 (lambda (conditions) 240 (catch 'match 241 (dolist (condition conditions) 242 (when (cond 243 ((eq condition t)) 244 ((stringp condition) 245 (string-match-p condition (buffer-name buffer))) 246 ((functionp condition) 247 (condition-case nil 248 (funcall condition buffer) 249 (wrong-number-of-arguments 250 (funcall condition buffer arg)))) 251 ((eq (car-safe condition) 'major-mode) 252 (eq 253 (buffer-local-value 'major-mode buffer) 254 (cdr condition))) 255 ((eq (car-safe condition) 'derived-mode) 256 (provided-mode-derived-p 257 (buffer-local-value 'major-mode buffer) 258 (cdr condition))) 259 ((eq (car-safe condition) 'not) 260 (not (funcall match (cdr condition)))) 261 ((eq (car-safe condition) 'or) 262 (funcall match (cdr condition))) 263 ((eq (car-safe condition) 'and) 264 (catch 'fail 265 (dolist (c (cdr condition)) 266 (unless (funcall match (list c)) 267 (throw 'fail nil))) 268 t))) 269 (throw 'match t))))))) 270 (funcall match (list condition)))) 271 272 (compat-defun match-buffers (condition &optional buffers arg) ;; <UNTESTED> 273 "Return a list of buffers that match CONDITION. 274 See `buffer-match' for details on CONDITION. By default all 275 buffers are checked, this can be restricted by passing an 276 optional argument BUFFERS, set to a list of buffers to check. 277 ARG is passed to `buffer-match', for predicate conditions in 278 CONDITION." 279 (let (bufs) 280 (dolist (buf (or buffers (buffer-list))) 281 (when (buffer-match-p condition (get-buffer buf) arg) 282 (push buf bufs))) 283 bufs)) 284 285 ;;;; Defined in subr-x.el 286 287 (compat-defun add-display-text-property (start end prop value ;; <OK> 288 &optional object) 289 "Add display property PROP with VALUE to the text from START to END. 290 If any text in the region has a non-nil `display' property, those 291 properties are retained. 292 293 If OBJECT is non-nil, it should be a string or a buffer. If nil, 294 this defaults to the current buffer." 295 (let ((sub-start start) 296 (sub-end 0) 297 disp) 298 (while (< sub-end end) 299 (setq sub-end (next-single-property-change sub-start 'display object 300 (if (stringp object) 301 (min (length object) end) 302 (min end (point-max))))) 303 (if (not (setq disp (get-text-property sub-start 'display object))) 304 ;; No old properties in this range. 305 (put-text-property sub-start sub-end 'display (list prop value) 306 object) 307 ;; We have old properties. 308 (let ((vector nil)) 309 ;; Make disp into a list. 310 (setq disp 311 (cond 312 ((vectorp disp) 313 (setq vector t) 314 (append disp nil)) 315 ((not (consp (car disp))) 316 (list disp)) 317 (t 318 disp))) 319 ;; Remove any old instances. 320 (when-let ((old (assoc prop disp))) 321 (setq disp (delete old disp))) 322 (setq disp (cons (list prop value) disp)) 323 (when vector 324 (setq disp (vconcat disp))) 325 ;; Finally update the range. 326 (put-text-property sub-start sub-end 'display disp object))) 327 (setq sub-start sub-end)))) 328 329 (compat-defmacro while-let (spec &rest body) ;; <OK> 330 "Bind variables according to SPEC and conditionally evaluate BODY. 331 Evaluate each binding in turn, stopping if a binding value is nil. 332 If all bindings are non-nil, eval BODY and repeat. 333 334 The variable list SPEC is the same as in `if-let'." 335 (declare (indent 1) (debug if-let)) 336 (when (and (<= (length spec) 2) (not (listp (car spec)))) 337 ;; Adjust the single binding case 338 (setq spec (list spec))) 339 (let ((done (gensym "done"))) 340 `(catch ',done 341 (while t 342 (if-let* ,spec 343 (progn 344 ,@body) 345 (throw ',done nil)))))) 346 347 ;;;; Defined in files.el 348 349 (compat-defun file-name-split (filename) ;; <OK> 350 "Return a list of all the components of FILENAME. 351 On most systems, this will be true: 352 353 (equal (string-join (file-name-split filename) \"/\") filename)" 354 (let ((components nil)) 355 ;; If this is a directory file name, then we have a null file name 356 ;; at the end. 357 (when (directory-name-p filename) 358 (push "" components) 359 (setq filename (directory-file-name filename))) 360 ;; Loop, chopping off components. 361 (while (length> filename 0) 362 (push (file-name-nondirectory filename) components) 363 (let ((dir (file-name-directory filename))) 364 (setq filename (and dir (directory-file-name dir))) 365 ;; If there's nothing left to peel off, we're at the root and 366 ;; we can stop. 367 (when (and dir (equal dir filename)) 368 (push (if (equal dir "") "" 369 ;; On Windows, the first component might be "c:" or 370 ;; the like. 371 (substring dir 0 -1)) 372 components) 373 (setq filename nil)))) 374 components)) 375 376 (compat-defun file-attribute-file-identifier (attributes) ;; <OK> 377 "The inode and device numbers in ATTRIBUTES returned by `file-attributes'. 378 The value is a list of the form (INODENUM DEVICE), where DEVICE could be 379 either a single number or a cons cell of two numbers. 380 This tuple of numbers uniquely identifies the file." 381 (nthcdr 10 attributes)) 382 383 (compat-defun file-name-parent-directory (filename) ;; <OK> 384 "Return the directory name of the parent directory of FILENAME. 385 If FILENAME is at the root of the filesystem, return nil. 386 If FILENAME is relative, it is interpreted to be relative 387 to `default-directory', and the result will also be relative." 388 (let* ((expanded-filename (expand-file-name filename)) 389 (parent (file-name-directory (directory-file-name expanded-filename)))) 390 (cond 391 ;; filename is at top-level, therefore no parent 392 ((or (null parent) 393 ;; `equal' is enough, we don't need to resolve symlinks here 394 ;; with `file-equal-p', also for performance 395 (equal parent expanded-filename)) 396 nil) 397 ;; filename is relative, return relative parent 398 ((not (file-name-absolute-p filename)) 399 (file-relative-name parent)) 400 (t 401 parent)))) 402 403 (compat-defvar file-has-changed-p--hash-table ;; <UNTESTED> 404 (make-hash-table :test #'equal) 405 "Internal variable used by `file-has-changed-p'.") 406 407 (compat-defun file-has-changed-p (file &optional tag) ;; <UNTESTED> 408 "Return non-nil if FILE has changed. 409 The size and modification time of FILE are compared to the size 410 and modification time of the same FILE during a previous 411 invocation of `file-has-changed-p'. Thus, the first invocation 412 of `file-has-changed-p' always returns non-nil when FILE exists. 413 The optional argument TAG, which must be a symbol, can be used to 414 limit the comparison to invocations with identical tags; it can be 415 the symbol of the calling function, for example." 416 (let* ((file (directory-file-name (expand-file-name file))) 417 (remote-file-name-inhibit-cache t) 418 (fileattr (file-attributes file 'integer)) 419 (attr (and fileattr 420 (cons (file-attribute-size fileattr) 421 (file-attribute-modification-time fileattr)))) 422 (sym (concat (symbol-name tag) "@" file)) 423 (cachedattr (gethash sym file-has-changed-p--hash-table))) 424 (when (not (equal attr cachedattr)) 425 (puthash sym attr file-has-changed-p--hash-table)))) 426 427 ;;;; Defined in keymap.el 428 429 (compat-defun key-valid-p (keys) ;; <OK> 430 "Say whether KEYS is a valid key. 431 A key is a string consisting of one or more key strokes. 432 The key strokes are separated by single space characters. 433 434 Each key stroke is either a single character, or the name of an 435 event, surrounded by angle brackets. In addition, any key stroke 436 may be preceded by one or more modifier keys. Finally, a limited 437 number of characters have a special shorthand syntax. 438 439 Here's some example key sequences. 440 441 \"f\" (the key `f') 442 \"S o m\" (a three key sequence of the keys `S', `o' and `m') 443 \"C-c o\" (a two key sequence of the keys `c' with the control modifier 444 and then the key `o') 445 \"H-<left>\" (the key named \"left\" with the hyper modifier) 446 \"M-RET\" (the \"return\" key with a meta modifier) 447 \"C-M-<space>\" (the \"space\" key with both the control and meta modifiers) 448 449 These are the characters that have shorthand syntax: 450 NUL, RET, TAB, LFD, ESC, SPC, DEL. 451 452 Modifiers have to be specified in this order: 453 454 A-C-H-M-S-s 455 456 which is 457 458 Alt-Control-Hyper-Meta-Shift-super" 459 (declare (pure t) (side-effect-free t)) 460 (let ((case-fold-search nil)) 461 (and 462 (stringp keys) 463 (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) 464 (save-match-data 465 (catch 'exit 466 (let ((prefixes 467 "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?")) 468 (dolist (key (split-string keys " ")) 469 ;; Every key might have these modifiers, and they should be 470 ;; in this order. 471 (when (string-match (concat "\\`" prefixes) key) 472 (setq key (substring key (match-end 0)))) 473 (unless (or (and (= (length key) 1) 474 ;; Don't accept control characters as keys. 475 (not (< (aref key 0) ?\s)) 476 ;; Don't accept Meta'd characters as keys. 477 (or (multibyte-string-p key) 478 (not (<= 127 (aref key 0) 255)))) 479 (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) 480 ;; Don't allow <M-C-down>. 481 (= (progn 482 (string-match 483 (concat "\\`<" prefixes) key) 484 (match-end 0)) 485 1)) 486 (string-match-p 487 "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" 488 key)) 489 ;; Invalid. 490 (throw 'exit nil))) 491 t)))))) 492 493 (compat-defun keymap--check (key) ;; <OK> 494 "Signal an error if KEY doesn't have a valid syntax." 495 (unless (key-valid-p key) 496 (error "%S is not a valid key definition; see `key-valid-p'" key))) 497 498 (compat-defun key-parse (keys) ;; <OK> 499 "Convert KEYS to the internal Emacs key representation. 500 See `kbd' for a descripion of KEYS." 501 (declare (pure t) (side-effect-free t)) 502 ;; A pure function is expected to preserve the match data. 503 (save-match-data 504 (let ((case-fold-search nil) 505 (len (length keys)) ; We won't alter keys in the loop below. 506 (pos 0) 507 (res [])) 508 (while (and (< pos len) 509 (string-match "[^ \t\n\f]+" keys pos)) 510 (let* ((word-beg (match-beginning 0)) 511 (word-end (match-end 0)) 512 (word (substring keys word-beg len)) 513 (times 1) 514 key) 515 ;; Try to catch events of the form "<as df>". 516 (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) 517 (setq word (match-string 0 word) 518 pos (+ word-beg (match-end 0))) 519 (setq word (substring keys word-beg word-end) 520 pos word-end)) 521 (when (string-match "\\([0-9]+\\)\\*." word) 522 (setq times (string-to-number (substring word 0 (match-end 1)))) 523 (setq word (substring word (1+ (match-end 1))))) 524 (cond ((string-match "^<<.+>>$" word) 525 (setq key (vconcat (if (eq (key-binding [?\M-x]) 526 'execute-extended-command) 527 [?\M-x] 528 (or (car (where-is-internal 529 'execute-extended-command)) 530 [?\M-x])) 531 (substring word 2 -2) "\r"))) 532 ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) 533 (progn 534 (setq word (concat (match-string 1 word) 535 (match-string 3 word))) 536 (not (string-match 537 "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" 538 word)))) 539 (setq key (list (intern word)))) 540 ((or (equal word "REM") (string-match "^;;" word)) 541 (setq pos (string-match "$" keys pos))) 542 (t 543 (let ((orig-word word) (prefix 0) (bits 0)) 544 (while (string-match "^[ACHMsS]-." word) 545 (setq bits (+ bits 546 (cdr 547 (assq (aref word 0) 548 '((?A . ?\A-\0) (?C . ?\C-\0) 549 (?H . ?\H-\0) (?M . ?\M-\0) 550 (?s . ?\s-\0) (?S . ?\S-\0)))))) 551 (setq prefix (+ prefix 2)) 552 (setq word (substring word 2))) 553 (when (string-match "^\\^.$" word) 554 (setq bits (+ bits ?\C-\0)) 555 (setq prefix (1+ prefix)) 556 (setq word (substring word 1))) 557 (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") 558 ("LFD" . "\n") ("TAB" . "\t") 559 ("ESC" . "\e") ("SPC" . " ") 560 ("DEL" . "\177"))))) 561 (when found (setq word (cdr found)))) 562 (when (string-match "^\\\\[0-7]+$" word) 563 (let ((n 0)) 564 (dolist (ch (cdr (string-to-list word))) 565 (setq n (+ (* n 8) ch -48))) 566 (setq word (vector n)))) 567 (cond ((= bits 0) 568 (setq key word)) 569 ((and (= bits ?\M-\0) (stringp word) 570 (string-match "^-?[0-9]+$" word)) 571 (setq key (mapcar (lambda (x) (+ x bits)) 572 (append word nil)))) 573 ((/= (length word) 1) 574 (error "%s must prefix a single character, not %s" 575 (substring orig-word 0 prefix) word)) 576 ((and (/= (logand bits ?\C-\0) 0) (stringp word) 577 ;; We used to accept . and ? here, 578 ;; but . is simply wrong, 579 ;; and C-? is not used (we use DEL instead). 580 (string-match "[@-_a-z]" word)) 581 (setq key (list (+ bits (- ?\C-\0) 582 (logand (aref word 0) 31))))) 583 (t 584 (setq key (list (+ bits (aref word 0))))))))) 585 (when key 586 (dolist (_ (number-sequence 1 times)) 587 (setq res (vconcat res key)))))) 588 res))) 589 590 (compat-defun keymap-set (keymap key definition) ;; <OK> 591 "Set KEY to DEFINITION in KEYMAP. 592 KEY is a string that satisfies `key-valid-p'. 593 594 DEFINITION is anything that can be a key's definition: 595 nil (means key is undefined in this keymap), 596 a command (a Lisp function suitable for interactive calling), 597 a string (treated as a keyboard macro), 598 a keymap (to define a prefix key), 599 a symbol (when the key is looked up, the symbol will stand for its 600 function definition, which should at that time be one of the above, 601 or another symbol whose function definition is used, etc.), 602 a cons (STRING . DEFN), meaning that DEFN is the definition 603 (DEFN should be a valid definition in its own right) and 604 STRING is the menu item name (which is used only if the containing 605 keymap has been created with a menu name, see `make-keymap'), 606 or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP, 607 or an extended menu item definition. 608 (See info node `(elisp)Extended Menu Items'.)" 609 (keymap--check key) 610 (when (stringp definition) 611 (keymap--check definition) 612 (setq definition (key-parse definition))) 613 (define-key keymap (key-parse key) definition)) 614 615 (compat-defun keymap-unset (keymap key &optional remove) ;; <UNTESTED> 616 "Remove key sequence KEY from KEYMAP. 617 KEY is a string that satisfies `key-valid-p'. 618 619 If REMOVE, remove the binding instead of unsetting it. This only 620 makes a difference when there's a parent keymap. When unsetting 621 a key in a child map, it will still shadow the same key in the 622 parent keymap. Removing the binding will allow the key in the 623 parent keymap to be used." 624 (keymap--check key) 625 (compat--define-key keymap (key-parse key) nil remove)) 626 627 (compat-defun keymap-global-set (key command) ;; <OK> 628 "Give KEY a global binding as COMMAND. 629 COMMAND is the command definition to use; usually it is 630 a symbol naming an interactively-callable function. 631 632 KEY is a string that satisfies `key-valid-p'. 633 634 Note that if KEY has a local binding in the current buffer, 635 that local binding will continue to shadow any global binding 636 that you make with this function. 637 638 NOTE: The compatibility version is not a command." 639 (keymap-set (current-global-map) key command)) 640 641 (compat-defun keymap-local-set (key command) ;; <OK> 642 "Give KEY a local binding as COMMAND. 643 COMMAND is the command definition to use; usually it is 644 a symbol naming an interactively-callable function. 645 646 KEY is a string that satisfies `key-valid-p'. 647 648 The binding goes in the current buffer's local map, which in most 649 cases is shared with all other buffers in the same major mode. 650 651 NOTE: The compatibility version is not a command." 652 (let ((map (current-local-map))) 653 (unless map 654 (use-local-map (setq map (make-sparse-keymap)))) 655 (keymap-set map key command))) 656 657 (compat-defun keymap-global-unset (key &optional remove) ;; <UNTESTED> 658 "Remove global binding of KEY (if any). 659 KEY is a string that satisfies `key-valid-p'. 660 661 If REMOVE (interactively, the prefix arg), remove the binding 662 instead of unsetting it. See `keymap-unset' for details. 663 664 NOTE: The compatibility version is not a command." 665 (keymap-unset (current-global-map) key remove)) 666 667 (compat-defun keymap-local-unset (key &optional remove) ;; <UNTESTED> 668 "Remove local binding of KEY (if any). 669 KEY is a string that satisfies `key-valid-p'. 670 671 If REMOVE (interactively, the prefix arg), remove the binding 672 instead of unsetting it. See `keymap-unset' for details. 673 674 NOTE: The compatibility version is not a command." 675 (when (current-local-map) 676 (keymap-unset (current-local-map) key remove))) 677 678 (compat-defun keymap-substitute (keymap olddef newdef &optional oldmap prefix) ;; <UNTESTED> 679 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. 680 In other words, OLDDEF is replaced with NEWDEF wherever it appears. 681 Alternatively, if optional fourth argument OLDMAP is specified, we redefine 682 in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. 683 684 If you don't specify OLDMAP, you can usually get the same results 685 in a cleaner way with command remapping, like this: 686 (define-key KEYMAP [remap OLDDEF] NEWDEF) 687 \n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" 688 ;; Don't document PREFIX in the doc string because we don't want to 689 ;; advertise it. It's meant for recursive calls only. Here's its 690 ;; meaning 691 692 ;; If optional argument PREFIX is specified, it should be a key 693 ;; prefix, a string. Redefined bindings will then be bound to the 694 ;; original key, with PREFIX added at the front. 695 (unless prefix 696 (setq prefix "")) 697 (let* ((scan (or oldmap keymap)) 698 (prefix1 (vconcat prefix [nil])) 699 (key-substitution-in-progress 700 (cons scan key-substitution-in-progress))) 701 ;; Scan OLDMAP, finding each char or event-symbol that 702 ;; has any definition, and act on it with hack-key. 703 (map-keymap 704 (lambda (char defn) 705 (aset prefix1 (length prefix) char) 706 (substitute-key-definition-key defn olddef newdef prefix1 keymap)) 707 scan))) 708 709 (compat-defun keymap-set-after (keymap key definition &optional after) ;; <UNTESTED> 710 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. 711 This is like `keymap-set' except that the binding for KEY is placed 712 just after the binding for the event AFTER, instead of at the beginning 713 of the map. Note that AFTER must be an event type (like KEY), NOT a command 714 \(like DEFINITION). 715 716 If AFTER is t or omitted, the new binding goes at the end of the keymap. 717 AFTER should be a single event type--a symbol or a character, not a sequence. 718 719 Bindings are always added before any inherited map. 720 721 The order of bindings in a keymap matters only when it is used as 722 a menu, so this function is not useful for non-menu keymaps." 723 (keymap--check key) 724 (when after 725 (keymap--check after)) 726 (define-key-after keymap (key-parse key) definition 727 (and after (key-parse after)))) 728 729 (compat-defun keymap-lookup ;; <OK> 730 (keymap key &optional accept-default no-remap position) 731 "Return the binding for command KEY. 732 KEY is a string that satisfies `key-valid-p'. 733 734 If KEYMAP is nil, look up in the current keymaps. If non-nil, it 735 should either be a keymap or a list of keymaps, and only these 736 keymap(s) will be consulted. 737 738 The binding is probably a symbol with a function definition. 739 740 Normally, `keymap-lookup' ignores bindings for t, which act as 741 default bindings, used when nothing else in the keymap applies; 742 this makes it usable as a general function for probing keymaps. 743 However, if the optional second argument ACCEPT-DEFAULT is 744 non-nil, `keymap-lookup' does recognize the default bindings, 745 just as `read-key-sequence' does. 746 747 Like the normal command loop, `keymap-lookup' will remap the 748 command resulting from looking up KEY by looking up the command 749 in the current keymaps. However, if the optional third argument 750 NO-REMAP is non-nil, `keymap-lookup' returns the unmapped 751 command. 752 753 If KEY is a key sequence initiated with the mouse, the used keymaps 754 will depend on the clicked mouse position with regard to the buffer 755 and possible local keymaps on strings. 756 757 If the optional argument POSITION is non-nil, it specifies a mouse 758 position as returned by `event-start' and `event-end', and the lookup 759 occurs in the keymaps associated with it instead of KEY. It can also 760 be a number or marker, in which case the keymap properties at the 761 specified buffer position instead of point are used." 762 (keymap--check key) 763 (when (and keymap position) 764 (error "Can't pass in both keymap and position")) 765 (if keymap 766 (let ((value (lookup-key keymap (key-parse key) accept-default))) 767 (if (and (not no-remap) 768 (symbolp value)) 769 (or (command-remapping value) value) 770 value)) 771 (key-binding (kbd key) accept-default no-remap position))) 772 773 (compat-defun keymap-local-lookup (keys &optional accept-default) ;; <OK> 774 "Return the binding for command KEYS in current local keymap only. 775 KEY is a string that satisfies `key-valid-p'. 776 777 The binding is probably a symbol with a function definition. 778 779 If optional argument ACCEPT-DEFAULT is non-nil, recognize default 780 bindings; see the description of `keymap-lookup' for more details 781 about this." 782 (when-let ((map (current-local-map))) 783 (keymap-lookup map keys accept-default))) 784 785 (compat-defun keymap-global-lookup (keys &optional accept-default _message) ;; <OK> 786 "Return the binding for command KEYS in current global keymap only. 787 KEY is a string that satisfies `key-valid-p'. 788 789 The binding is probably a symbol with a function definition. 790 This function's return values are the same as those of `keymap-lookup' 791 \(which see). 792 793 If optional argument ACCEPT-DEFAULT is non-nil, recognize default 794 bindings; see the description of `keymap-lookup' for more details 795 about this. 796 797 NOTE: The compatibility version is not a command." 798 (keymap-lookup (current-global-map) keys accept-default)) 799 800 (compat-defun define-keymap (&rest definitions) ;; <OK> 801 "Create a new keymap and define KEY/DEFINITION pairs as key bindings. 802 The new keymap is returned. 803 804 Options can be given as keywords before the KEY/DEFINITION 805 pairs. Available keywords are: 806 807 :full If non-nil, create a chartable alist (see `make-keymap'). 808 If nil (i.e., the default), create a sparse keymap (see 809 `make-sparse-keymap'). 810 811 :suppress If non-nil, the keymap will be suppressed (see `suppress-keymap'). 812 If `nodigits', treat digits like other chars. 813 814 :parent If non-nil, this should be a keymap to use as the parent 815 (see `set-keymap-parent'). 816 817 :keymap If non-nil, instead of creating a new keymap, the given keymap 818 will be destructively modified instead. 819 820 :name If non-nil, this should be a string to use as the menu for 821 the keymap in case you use it as a menu with `x-popup-menu'. 822 823 :prefix If non-nil, this should be a symbol to be used as a prefix 824 command (see `define-prefix-command'). If this is the case, 825 this symbol is returned instead of the map itself. 826 827 KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can 828 also be the special symbol `:menu', in which case DEFINITION 829 should be a MENU form as accepted by `easy-menu-define'. 830 831 \(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" 832 (declare (indent defun)) 833 (let (full suppress parent name prefix keymap) 834 ;; Handle keywords. 835 (while (and definitions 836 (keywordp (car definitions)) 837 (not (eq (car definitions) :menu))) 838 (let ((keyword (pop definitions))) 839 (unless definitions 840 (error "Missing keyword value for %s" keyword)) 841 (let ((value (pop definitions))) 842 (pcase keyword 843 (:full (setq full value)) 844 (:keymap (setq keymap value)) 845 (:parent (setq parent value)) 846 (:suppress (setq suppress value)) 847 (:name (setq name value)) 848 (:prefix (setq prefix value)) 849 (_ (error "Invalid keyword: %s" keyword)))))) 850 851 (when (and prefix 852 (or full parent suppress keymap)) 853 (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords")) 854 855 (when (and keymap full) 856 (error "Invalid combination: :keymap with :full")) 857 858 (let ((keymap (cond 859 (keymap keymap) 860 (prefix (define-prefix-command prefix nil name)) 861 (full (make-keymap name)) 862 (t (make-sparse-keymap name)))) 863 seen-keys) 864 (when suppress 865 (suppress-keymap keymap (eq suppress 'nodigits))) 866 (when parent 867 (set-keymap-parent keymap parent)) 868 869 ;; Do the bindings. 870 (while definitions 871 (let ((key (pop definitions))) 872 (unless definitions 873 (error "Uneven number of key/definition pairs")) 874 (let ((def (pop definitions))) 875 (if (eq key :menu) 876 (easy-menu-define nil keymap "" def) 877 (if (member key seen-keys) 878 (error "Duplicate definition for key: %S %s" key keymap) 879 (push key seen-keys)) 880 (keymap-set keymap key def))))) 881 keymap))) 882 883 (compat-defmacro defvar-keymap (variable-name &rest defs) ;; <OK> 884 "Define VARIABLE-NAME as a variable with a keymap definition. 885 See `define-keymap' for an explanation of the keywords and KEY/DEFINITION. 886 887 In addition to the keywords accepted by `define-keymap', this 888 macro also accepts a `:doc' keyword, which (if present) is used 889 as the variable documentation string. 890 891 The `:repeat' keyword can also be specified; it controls the 892 `repeat-mode' behavior of the bindings in the keymap. When it is 893 non-nil, all commands in the map will have the `repeat-map' 894 symbol property. 895 896 More control is available over which commands are repeatable; the 897 value can also be a property list with properties `:enter' and 898 `:exit', for example: 899 900 :repeat (:enter (commands ...) :exit (commands ...)) 901 902 `:enter' specifies the list of additional commands that only 903 enter `repeat-mode'. When the list is empty, then by default all 904 commands in the map enter `repeat-mode'. This is useful when 905 there is a command that has the `repeat-map' symbol property, but 906 doesn't exist in this specific map. `:exit' is a list of 907 commands that exit `repeat-mode'. When the list is empty, no 908 commands in the map exit `repeat-mode'. This is useful when a 909 command exists in this specific map, but it doesn't have the 910 `repeat-map' symbol property on its symbol. 911 912 \(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP REPEAT &rest [KEY DEFINITION]...)" 913 (declare (indent 1)) 914 (let ((opts nil) 915 doc repeat props) 916 (while (and defs 917 (keywordp (car defs)) 918 (not (eq (car defs) :menu))) 919 (let ((keyword (pop defs))) 920 (unless defs 921 (error "Uneven number of keywords")) 922 (cond 923 ((eq keyword :doc) (setq doc (pop defs))) 924 ((eq keyword :repeat) (setq repeat (pop defs))) 925 (t (push keyword opts) 926 (push (pop defs) opts))))) 927 (unless (zerop (% (length defs) 2)) 928 (error "Uneven number of key/definition pairs: %s" defs)) 929 930 (let ((defs defs) 931 key seen-keys) 932 (while defs 933 (setq key (pop defs)) 934 (pop defs) 935 (when (not (eq key :menu)) 936 (if (member key seen-keys) 937 (error "Duplicate definition for key '%s' in keymap '%s'" 938 key variable-name) 939 (push key seen-keys))))) 940 941 (when repeat 942 (let ((defs defs) 943 def) 944 (dolist (def (plist-get repeat :enter)) 945 (push `(put ',def 'repeat-map ',variable-name) props)) 946 (while defs 947 (pop defs) 948 (setq def (pop defs)) 949 (when (and (memq (car def) '(function quote)) 950 (not (memq (cadr def) (plist-get repeat :exit)))) 951 (push `(put ,def 'repeat-map ',variable-name) props))))) 952 953 (let ((defvar-form 954 `(defvar ,variable-name 955 (define-keymap ,@(nreverse opts) ,@defs) 956 ,@(and doc (list doc))))) 957 (if props 958 `(progn 959 ,defvar-form 960 ,@(nreverse props)) 961 defvar-form)))) 962 963 ;;;; Defined in button.el 964 965 (compat-defun button--properties (callback data help-echo) ;; <OK> 966 "Helper function." 967 (list 'font-lock-face 'button 968 'mouse-face 'highlight 969 'help-echo help-echo 970 'button t 971 'follow-link t 972 'category t 973 'button-data data 974 'keymap button-map 975 'action callback)) 976 977 (compat-defun buttonize (string callback &optional data help-echo) ;; <OK> 978 "Make STRING into a button and return it. 979 When clicked, CALLBACK will be called with the DATA as the 980 function argument. If DATA isn't present (or is nil), the button 981 itself will be used instead as the function argument. 982 983 If HELP-ECHO, use that as the `help-echo' property. 984 985 Also see `buttonize-region'." 986 (let ((string 987 (apply #'propertize string 988 (button--properties callback data help-echo)))) 989 ;; Add the face to the end so that it can be overridden. 990 (add-face-text-property 0 (length string) 'button t string) 991 string)) 992 993 (compat-defun buttonize-region (start end callback &optional data help-echo) ;; <OK> 994 "Make the region between START and END into a button. 995 When clicked, CALLBACK will be called with the DATA as the 996 function argument. If DATA isn't present (or is nil), the button 997 itself will be used instead as the function argument. 998 999 If HELP-ECHO, use that as the `help-echo' property. 1000 1001 Also see `buttonize'." 1002 (add-text-properties start end (button--properties callback data help-echo)) 1003 (add-face-text-property start end 'button t)) 1004 1005 ;; Obsolete Alias since 29 1006 (compat-defalias button-buttonize buttonize :obsolete t) 1007 1008 (provide 'compat-29) 1009 ;;; compat-29.el ends here