1;;; subr.el --- basic lisp subroutines for Emacs -*- lexical-binding:t -*- 2 3;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2021 Free Software 4;; Foundation, Inc. 5 6;; Maintainer: emacs-devel@gnu.org 7;; Keywords: internal 8;; Package: emacs 9 10;; This file is part of GNU Emacs. 11 12;; GNU Emacs is free software: you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation, either version 3 of the License, or 15;; (at your option) any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 24 25;;; Commentary: 26 27;;; Code: 28 29;; declare-function's args use &rest, not &optional, for compatibility 30;; with byte-compile-macroexpand-declare-function. 31 32(defmacro declare-function (_fn _file &rest _args) 33 "Tell the byte-compiler that function FN is defined, in FILE. 34The FILE argument is not used by the byte-compiler, but by the 35`check-declare' package, which checks that FILE contains a 36definition for FN. (FILE can be nil, and that disables this 37check.) 38 39FILE can be either a Lisp file (in which case the \".el\" 40extension is optional), or a C file. C files are expanded 41relative to the Emacs \"src/\" directory. Lisp files are 42searched for using `locate-library', and if that fails they are 43expanded relative to the location of the file containing the 44declaration. A FILE with an \"ext:\" prefix is an external file. 45`check-declare' will check such files if they are found, and skip 46them without error if they are not. 47 48Optional ARGLIST specifies FN's arguments, or is t to not specify 49FN's arguments. An omitted ARGLIST defaults to t, not nil: a nil 50ARGLIST specifies an empty argument list, and an explicit t 51ARGLIST is a placeholder that allows supplying a later arg. 52 53Optional FILEONLY non-nil means that `check-declare' will check 54only that FILE exists, not that it defines FN. This is intended 55for function definitions that `check-declare' does not recognize, 56e.g., `defstruct'. 57 58Note that for the purposes of `check-declare', this statement 59must be the first non-whitespace on a line. 60 61For more information, see Info node `(elisp)Declaring Functions'." 62 (declare (advertised-calling-convention 63 (fn file &optional arglist fileonly) nil)) 64 ;; Does nothing - `byte-compile-macroexpand-declare-function' does 65 ;; the work. 66 nil) 67 68 69;;;; Basic Lisp macros. 70 71(defalias 'not #'null) 72(defalias 'sxhash #'sxhash-equal) 73 74(defmacro noreturn (form) 75 "Evaluate FORM, expecting it not to return. 76If FORM does return, signal an error." 77 (declare (debug t)) 78 `(prog1 ,form 79 (error "Form marked with `noreturn' did return"))) 80 81(defmacro 1value (form) 82 "Evaluate FORM, expecting a constant return value. 83If FORM returns differing values when running under Testcover, 84Testcover will raise an error." 85 (declare (debug t)) 86 form) 87 88(defmacro def-edebug-spec (symbol spec) 89 "Set the Edebug SPEC to use for sexps which have SYMBOL as head. 90Both SYMBOL and SPEC are unevaluated. The SPEC can be: 910 (instrument no arguments); t (instrument all arguments); 92a symbol (naming a function with an Edebug specification); or a list. 93The elements of the list describe the argument types; see 94Info node `(elisp)Specification List' for details." 95 (declare (indent 1)) 96 `(put (quote ,symbol) 'edebug-form-spec (quote ,spec))) 97 98(defun def-edebug-elem-spec (name spec) 99 "Define a new Edebug spec element NAME as shorthand for SPEC. 100The SPEC has to be a list." 101 (declare (indent 1)) 102 (when (string-match "\\`[&:]" (symbol-name name)) 103 ;; & and : have special meaning in spec element names. 104 (error "Edebug spec name cannot start with '&' or ':'")) 105 (unless (consp spec) 106 (error "Edebug spec has to be a list: %S" spec)) 107 (put name 'edebug-elem-spec spec)) 108 109 110(defmacro lambda (&rest cdr) 111 "Return an anonymous function. 112Under dynamic binding, a call of the form (lambda ARGS DOCSTRING 113INTERACTIVE BODY) is self-quoting; the result of evaluating the 114lambda expression is the expression itself. Under lexical 115binding, the result is a closure. Regardless, the result is a 116function, i.e., it may be stored as the function value of a 117symbol, passed to `funcall' or `mapcar', etc. 118 119ARGS should take the same form as an argument list for a `defun'. 120DOCSTRING is an optional documentation string. 121 If present, it should describe how to call the function. 122 But documentation strings are usually not useful in nameless functions. 123INTERACTIVE should be a call to the function `interactive', which see. 124It may also be omitted. 125BODY should be a list of Lisp expressions. 126 127\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)" 128 (declare (doc-string 2) (indent defun) 129 (debug (&define lambda-list lambda-doc 130 [&optional ("interactive" interactive)] 131 def-body))) 132 ;; Note that this definition should not use backquotes; subr.el should not 133 ;; depend on backquote.el. 134 (list 'function (cons 'lambda cdr))) 135 136(defmacro prog2 (form1 form2 &rest body) 137 "Eval FORM1, FORM2 and BODY sequentially; return value from FORM2. 138The value of FORM2 is saved during the evaluation of the 139remaining args, whose values are discarded." 140 (declare (indent 2) (debug t)) 141 `(progn ,form1 (prog1 ,form2 ,@body))) 142 143(defmacro setq-default (&rest args) 144 "Set the default value of variable VAR to VALUE. 145VAR, the variable name, is literal (not evaluated); 146VALUE is an expression: it is evaluated and its value returned. 147The default value of a variable is seen in buffers 148that do not have their own values for the variable. 149 150More generally, you can use multiple variables and values, as in 151 (setq-default VAR VALUE VAR VALUE...) 152This sets each VAR's default value to the corresponding VALUE. 153The VALUE for the Nth VAR can refer to the new default values 154of previous VARs. 155 156\(fn [VAR VALUE]...)" 157 (declare (debug setq)) 158 (let ((exps nil)) 159 (while args 160 (push `(set-default ',(pop args) ,(pop args)) exps)) 161 `(progn . ,(nreverse exps)))) 162 163(defmacro setq-local (&rest pairs) 164 "Make variables in PAIRS buffer-local and assign them the corresponding values. 165 166PAIRS is a list of variable/value pairs. For each variable, make 167it buffer-local and assign it the corresponding value. The 168variables are literal symbols and should not be quoted. 169 170The second VALUE is not computed until after the first VARIABLE 171is set, and so on; each VALUE can use the new value of variables 172set earlier in the `setq-local'. The return value of the 173`setq-local' form is the value of the last VALUE. 174 175\(fn [VARIABLE VALUE]...)" 176 (declare (debug setq)) 177 (unless (zerop (mod (length pairs) 2)) 178 (error "PAIRS must have an even number of variable/value members")) 179 (let ((expr nil)) 180 (while pairs 181 (unless (symbolp (car pairs)) 182 (error "Attempting to set a non-symbol: %s" (car pairs))) 183 ;; Can't use backquote here, it's too early in the bootstrap. 184 (setq expr 185 (cons 186 (list 'set 187 (list 'make-local-variable (list 'quote (car pairs))) 188 (car (cdr pairs))) 189 expr)) 190 (setq pairs (cdr (cdr pairs)))) 191 (macroexp-progn (nreverse expr)))) 192 193(defmacro defvar-local (var val &optional docstring) 194 "Define VAR as a buffer-local variable with default value VAL. 195Like `defvar' but additionally marks the variable as being automatically 196buffer-local wherever it is set." 197 (declare (debug defvar) (doc-string 3) (indent 2)) 198 ;; Can't use backquote here, it's too early in the bootstrap. 199 (list 'progn (list 'defvar var val docstring) 200 (list 'make-variable-buffer-local (list 'quote var)))) 201 202(defun buffer-local-boundp (symbol buffer) 203 "Return non-nil if SYMBOL is bound in BUFFER. 204Also see `local-variable-p'." 205 (condition-case nil 206 (buffer-local-value symbol buffer) 207 (:success t) 208 (void-variable nil))) 209 210(defmacro push (newelt place) 211 "Add NEWELT to the list stored in the generalized variable PLACE. 212This is morally equivalent to (setf PLACE (cons NEWELT PLACE)), 213except that PLACE is evaluated only once (after NEWELT)." 214 (declare (debug (form gv-place))) 215 (if (symbolp place) 216 ;; Important special case, to avoid triggering GV too early in 217 ;; the bootstrap. 218 (list 'setq place 219 (list 'cons newelt place)) 220 (require 'macroexp) 221 (macroexp-let2 macroexp-copyable-p x newelt 222 (gv-letplace (getter setter) place 223 (funcall setter `(cons ,x ,getter)))))) 224 225(defmacro pop (place) 226 "Return the first element of PLACE's value, and remove it from the list. 227PLACE must be a generalized variable whose value is a list. 228If the value is nil, `pop' returns nil but does not actually 229change the list." 230 (declare (debug (gv-place))) 231 ;; We use `car-safe' here instead of `car' because the behavior is the same 232 ;; (if it's not a cons cell, the `cdr' would have signaled an error already), 233 ;; but `car-safe' is total, so the byte-compiler can safely remove it if the 234 ;; result is not used. 235 `(car-safe 236 ,(if (symbolp place) 237 ;; So we can use `pop' in the bootstrap before `gv' can be used. 238 (list 'prog1 place (list 'setq place (list 'cdr place))) 239 (gv-letplace (getter setter) place 240 (macroexp-let2 macroexp-copyable-p x getter 241 `(prog1 ,x ,(funcall setter `(cdr ,x)))))))) 242 243(defmacro when (cond &rest body) 244 "If COND yields non-nil, do BODY, else return nil. 245When COND yields non-nil, eval BODY forms sequentially and return 246value of last one, or nil if there are none. 247 248\(fn COND BODY...)" 249 (declare (indent 1) (debug t)) 250 (list 'if cond (cons 'progn body))) 251 252(defmacro unless (cond &rest body) 253 "If COND yields nil, do BODY, else return nil. 254When COND yields nil, eval BODY forms sequentially and return 255value of last one, or nil if there are none. 256 257\(fn COND BODY...)" 258 (declare (indent 1) (debug t)) 259 (cons 'if (cons cond (cons nil body)))) 260 261(defsubst subr-primitive-p (object) 262 "Return t if OBJECT is a built-in primitive function." 263 (and (subrp object) 264 (not (subr-native-elisp-p object)))) 265 266(defsubst xor (cond1 cond2) 267 "Return the boolean exclusive-or of COND1 and COND2. 268If only one of the arguments is non-nil, return it; otherwise 269return nil." 270 (declare (pure t) (side-effect-free error-free)) 271 (cond ((not cond1) cond2) 272 ((not cond2) cond1))) 273 274(defmacro dolist (spec &rest body) 275 "Loop over a list. 276Evaluate BODY with VAR bound to each car from LIST, in turn. 277Then evaluate RESULT to get return value, default nil. 278 279\(fn (VAR LIST [RESULT]) BODY...)" 280 (declare (indent 1) (debug ((symbolp form &optional form) body))) 281 (unless (consp spec) 282 (signal 'wrong-type-argument (list 'consp spec))) 283 (unless (<= 2 (length spec) 3) 284 (signal 'wrong-number-of-arguments (list '(2 . 3) (length spec)))) 285 ;; It would be cleaner to create an uninterned symbol, 286 ;; but that uses a lot more space when many functions in many files 287 ;; use dolist. 288 ;; FIXME: This cost disappears in byte-compiled lexical-binding files. 289 (let ((temp '--dolist-tail--)) 290 ;; This test does not matter much because both semantics are acceptable, 291 ;; but one is slightly faster with dynamic scoping and the other is 292 ;; slightly faster (and has cleaner semantics) with lexical scoping. 293 (if lexical-binding 294 `(let ((,temp ,(nth 1 spec))) 295 (while ,temp 296 (let ((,(car spec) (car ,temp))) 297 ,@body 298 (setq ,temp (cdr ,temp)))) 299 ,@(cdr (cdr spec))) 300 `(let ((,temp ,(nth 1 spec)) 301 ,(car spec)) 302 (while ,temp 303 (setq ,(car spec) (car ,temp)) 304 ,@body 305 (setq ,temp (cdr ,temp))) 306 ,@(if (cdr (cdr spec)) 307 `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))) 308 309(defmacro dotimes (spec &rest body) 310 "Loop a certain number of times. 311Evaluate BODY with VAR bound to successive integers running from 0, 312inclusive, to COUNT, exclusive. 313 314Finally RESULT is evaluated to get the return value (nil if 315RESULT is omitted). Using RESULT is deprecated, and may result 316in compilation warnings about unused variables. 317 318\(fn (VAR COUNT [RESULT]) BODY...)" 319 (declare (indent 1) (debug dolist)) 320 ;; It would be cleaner to create an uninterned symbol, 321 ;; but that uses a lot more space when many functions in many files 322 ;; use dotimes. 323 ;; FIXME: This cost disappears in byte-compiled lexical-binding files. 324 (let ((temp '--dotimes-limit--) 325 (start 0) 326 (end (nth 1 spec))) 327 ;; This test does not matter much because both semantics are acceptable, 328 ;; but one is slightly faster with dynamic scoping and the other has 329 ;; cleaner semantics. 330 (if lexical-binding 331 (let ((counter '--dotimes-counter--)) 332 `(let ((,temp ,end) 333 (,counter ,start)) 334 (while (< ,counter ,temp) 335 (let ((,(car spec) ,counter)) 336 ,@body) 337 (setq ,counter (1+ ,counter))) 338 ,@(if (cddr spec) 339 ;; FIXME: This let often leads to "unused var" warnings. 340 `((let ((,(car spec) ,counter)) ,@(cddr spec)))))) 341 `(let ((,temp ,end) 342 (,(car spec) ,start)) 343 (while (< ,(car spec) ,temp) 344 ,@body 345 (setq ,(car spec) (1+ ,(car spec)))) 346 ,@(cdr (cdr spec)))))) 347 348(defmacro declare (&rest _specs) 349 "Do not evaluate any arguments, and return nil. 350If a `declare' form appears as the first form in the body of a 351`defun' or `defmacro' form, SPECS specifies various additional 352information about the function or macro; these go into effect 353during the evaluation of the `defun' or `defmacro' form. 354 355The possible values of SPECS are specified by 356`defun-declarations-alist' and `macro-declarations-alist'. 357 358For more information, see info node `(elisp)Declare Form'." 359 ;; FIXME: edebug spec should pay attention to defun-declarations-alist. 360 nil) 361 362(defmacro ignore-errors (&rest body) 363 "Execute BODY; if an error occurs, return nil. 364Otherwise, return result of last form in BODY. 365See also `with-demoted-errors' that does something similar 366without silencing all errors." 367 (declare (debug t) (indent 0)) 368 `(condition-case nil (progn ,@body) (error nil))) 369 370(defmacro ignore-error (condition &rest body) 371 "Execute BODY; if the error CONDITION occurs, return nil. 372Otherwise, return result of last form in BODY. 373 374CONDITION can also be a list of error conditions." 375 (declare (debug t) (indent 1)) 376 `(condition-case nil (progn ,@body) (,condition nil))) 377 378;;;; Basic Lisp functions. 379 380(defvar gensym-counter 0 381 "Number used to construct the name of the next symbol created by `gensym'.") 382 383(defun gensym (&optional prefix) 384 "Return a new uninterned symbol. 385The name is made by appending `gensym-counter' to PREFIX. 386PREFIX is a string, and defaults to \"g\"." 387 (let ((num (prog1 gensym-counter 388 (setq gensym-counter (1+ gensym-counter))))) 389 (make-symbol (format "%s%d" (or prefix "g") num)))) 390 391(defun ignore (&rest _arguments) 392 "Do nothing and return nil. 393This function accepts any number of ARGUMENTS, but ignores them. 394Also see `always'." 395 (declare (completion ignore)) 396 (interactive) 397 nil) 398 399(defun always (&rest _arguments) 400 "Do nothing and return t. 401This function accepts any number of ARGUMENTS, but ignores them. 402Also see `ignore'." 403 t) 404 405;; Signal a compile-error if the first arg is missing. 406(defun error (&rest args) 407 "Signal an error, making a message by passing ARGS to `format-message'. 408Errors cause entry to the debugger when `debug-on-error' is non-nil. 409This can be overridden by `debug-ignored-errors'. 410 411To signal with MESSAGE without interpreting format characters 412like `%', `\\=`' and `\\='', use (error \"%s\" MESSAGE). 413In Emacs, the convention is that error messages start with a capital 414letter but *do not* end with a period. Please follow this convention 415for the sake of consistency." 416 (declare (advertised-calling-convention (string &rest args) "23.1")) 417 (signal 'error (list (apply #'format-message args)))) 418 419(defun user-error (format &rest args) 420 "Signal a user error, making a message by passing ARGS to `format-message'. 421This is like `error' except that a user error (or \"pilot error\") comes 422from an incorrect manipulation by the user, not from an actual problem. 423In contrast with other errors, user errors normally do not cause 424entry to the debugger, even when `debug-on-error' is non-nil. 425This can be overridden by `debug-ignored-errors'. 426 427To signal with MESSAGE without interpreting format characters 428like `%', `\\=`' and `\\='', use (user-error \"%s\" MESSAGE). 429In Emacs, the convention is that error messages start with a capital 430letter but *do not* end with a period. Please follow this convention 431for the sake of consistency." 432 (signal 'user-error (list (apply #'format-message format args)))) 433 434(defun define-error (name message &optional parent) 435 "Define NAME as a new error signal. 436MESSAGE is a string that will be output to the echo area if such an error 437is signaled without being caught by a `condition-case'. 438PARENT is either a signal or a list of signals from which it inherits. 439Defaults to `error'." 440 (unless parent (setq parent 'error)) 441 (let ((conditions 442 (if (consp parent) 443 (apply #'append 444 (mapcar (lambda (parent) 445 (cons parent 446 (or (get parent 'error-conditions) 447 (error "Unknown signal `%s'" parent)))) 448 parent)) 449 (cons parent (get parent 'error-conditions))))) 450 (put name 'error-conditions 451 (delete-dups (copy-sequence (cons name conditions)))) 452 (when message (put name 'error-message message)))) 453 454;; We put this here instead of in frame.el so that it's defined even on 455;; systems where frame.el isn't loaded. 456(defun frame-configuration-p (object) 457 "Return non-nil if OBJECT seems to be a frame configuration. 458Any list whose car is `frame-configuration' is assumed to be a frame 459configuration." 460 (and (consp object) 461 (eq (car object) 'frame-configuration))) 462 463(defun apply-partially (fun &rest args) 464 "Return a function that is a partial application of FUN to ARGS. 465ARGS is a list of the first N arguments to pass to FUN. 466The result is a new function which does the same as FUN, except that 467the first N arguments are fixed at the values with which this function 468was called." 469 (lambda (&rest args2) 470 (apply fun (append args args2)))) 471 472(defun zerop (number) 473 "Return t if NUMBER is zero." 474 ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because 475 ;; = has a byte-code. 476 (declare (compiler-macro (lambda (_) `(= 0 ,number)))) 477 (= 0 number)) 478 479(defun fixnump (object) 480 "Return t if OBJECT is a fixnum." 481 (and (integerp object) 482 (<= most-negative-fixnum object most-positive-fixnum))) 483 484(defun bignump (object) 485 "Return t if OBJECT is a bignum." 486 (and (integerp object) (not (fixnump object)))) 487 488(defun lsh (value count) 489 "Return VALUE with its bits shifted left by COUNT. 490If COUNT is negative, shifting is actually to the right. 491In this case, if VALUE is a negative fixnum treat it as unsigned, 492i.e., subtract 2 * `most-negative-fixnum' from VALUE before shifting it." 493 (when (and (< value 0) (< count 0)) 494 (when (< value most-negative-fixnum) 495 (signal 'args-out-of-range (list value count))) 496 (setq value (logand (ash value -1) most-positive-fixnum)) 497 (setq count (1+ count))) 498 (ash value count)) 499 500 501;;;; List functions. 502 503;; Note: `internal--compiler-macro-cXXr' was copied from 504;; `cl--compiler-macro-cXXr' in cl-macs.el. If you amend either one, 505;; you may want to amend the other, too. 506(defun internal--compiler-macro-cXXr (form x) 507 (let* ((head (car form)) 508 (n (symbol-name (car form))) 509 (i (- (length n) 2))) 510 (if (not (string-match "c[ad]+r\\'" n)) 511 (if (and (fboundp head) (symbolp (symbol-function head))) 512 (internal--compiler-macro-cXXr (cons (symbol-function head) (cdr form)) 513 x) 514 (error "Compiler macro for cXXr applied to non-cXXr form")) 515 (while (> i (match-beginning 0)) 516 (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x)) 517 (setq i (1- i))) 518 x))) 519 520(defun caar (x) 521 "Return the car of the car of X." 522 (declare (compiler-macro internal--compiler-macro-cXXr)) 523 (car (car x))) 524 525(defun cadr (x) 526 "Return the car of the cdr of X." 527 (declare (compiler-macro internal--compiler-macro-cXXr)) 528 (car (cdr x))) 529 530(defun cdar (x) 531 "Return the cdr of the car of X." 532 (declare (compiler-macro internal--compiler-macro-cXXr)) 533 (cdr (car x))) 534 535(defun cddr (x) 536 "Return the cdr of the cdr of X." 537 (declare (compiler-macro internal--compiler-macro-cXXr)) 538 (cdr (cdr x))) 539 540(defun caaar (x) 541 "Return the `car' of the `car' of the `car' of X." 542 (declare (compiler-macro internal--compiler-macro-cXXr)) 543 (car (car (car x)))) 544 545(defun caadr (x) 546 "Return the `car' of the `car' of the `cdr' of X." 547 (declare (compiler-macro internal--compiler-macro-cXXr)) 548 (car (car (cdr x)))) 549 550(defun cadar (x) 551 "Return the `car' of the `cdr' of the `car' of X." 552 (declare (compiler-macro internal--compiler-macro-cXXr)) 553 (car (cdr (car x)))) 554 555(defun caddr (x) 556 "Return the `car' of the `cdr' of the `cdr' of X." 557 (declare (compiler-macro internal--compiler-macro-cXXr)) 558 (car (cdr (cdr x)))) 559 560(defun cdaar (x) 561 "Return the `cdr' of the `car' of the `car' of X." 562 (declare (compiler-macro internal--compiler-macro-cXXr)) 563 (cdr (car (car x)))) 564 565(defun cdadr (x) 566 "Return the `cdr' of the `car' of the `cdr' of X." 567 (declare (compiler-macro internal--compiler-macro-cXXr)) 568 (cdr (car (cdr x)))) 569 570(defun cddar (x) 571 "Return the `cdr' of the `cdr' of the `car' of X." 572 (declare (compiler-macro internal--compiler-macro-cXXr)) 573 (cdr (cdr (car x)))) 574 575(defun cdddr (x) 576 "Return the `cdr' of the `cdr' of the `cdr' of X." 577 (declare (compiler-macro internal--compiler-macro-cXXr)) 578 (cdr (cdr (cdr x)))) 579 580(defun caaaar (x) 581 "Return the `car' of the `car' of the `car' of the `car' of X." 582 (declare (compiler-macro internal--compiler-macro-cXXr)) 583 (car (car (car (car x))))) 584 585(defun caaadr (x) 586 "Return the `car' of the `car' of the `car' of the `cdr' of X." 587 (declare (compiler-macro internal--compiler-macro-cXXr)) 588 (car (car (car (cdr x))))) 589 590(defun caadar (x) 591 "Return the `car' of the `car' of the `cdr' of the `car' of X." 592 (declare (compiler-macro internal--compiler-macro-cXXr)) 593 (car (car (cdr (car x))))) 594 595(defun caaddr (x) 596 "Return the `car' of the `car' of the `cdr' of the `cdr' of X." 597 (declare (compiler-macro internal--compiler-macro-cXXr)) 598 (car (car (cdr (cdr x))))) 599 600(defun cadaar (x) 601 "Return the `car' of the `cdr' of the `car' of the `car' of X." 602 (declare (compiler-macro internal--compiler-macro-cXXr)) 603 (car (cdr (car (car x))))) 604 605(defun cadadr (x) 606 "Return the `car' of the `cdr' of the `car' of the `cdr' of X." 607 (declare (compiler-macro internal--compiler-macro-cXXr)) 608 (car (cdr (car (cdr x))))) 609 610(defun caddar (x) 611 "Return the `car' of the `cdr' of the `cdr' of the `car' of X." 612 (declare (compiler-macro internal--compiler-macro-cXXr)) 613 (car (cdr (cdr (car x))))) 614 615(defun cadddr (x) 616 "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." 617 (declare (compiler-macro internal--compiler-macro-cXXr)) 618 (car (cdr (cdr (cdr x))))) 619 620(defun cdaaar (x) 621 "Return the `cdr' of the `car' of the `car' of the `car' of X." 622 (declare (compiler-macro internal--compiler-macro-cXXr)) 623 (cdr (car (car (car x))))) 624 625(defun cdaadr (x) 626 "Return the `cdr' of the `car' of the `car' of the `cdr' of X." 627 (declare (compiler-macro internal--compiler-macro-cXXr)) 628 (cdr (car (car (cdr x))))) 629 630(defun cdadar (x) 631 "Return the `cdr' of the `car' of the `cdr' of the `car' of X." 632 (declare (compiler-macro internal--compiler-macro-cXXr)) 633 (cdr (car (cdr (car x))))) 634 635(defun cdaddr (x) 636 "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." 637 (declare (compiler-macro internal--compiler-macro-cXXr)) 638 (cdr (car (cdr (cdr x))))) 639 640(defun cddaar (x) 641 "Return the `cdr' of the `cdr' of the `car' of the `car' of X." 642 (declare (compiler-macro internal--compiler-macro-cXXr)) 643 (cdr (cdr (car (car x))))) 644 645(defun cddadr (x) 646 "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." 647 (declare (compiler-macro internal--compiler-macro-cXXr)) 648 (cdr (cdr (car (cdr x))))) 649 650(defun cdddar (x) 651 "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." 652 (declare (compiler-macro internal--compiler-macro-cXXr)) 653 (cdr (cdr (cdr (car x))))) 654 655(defun cddddr (x) 656 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." 657 (declare (compiler-macro internal--compiler-macro-cXXr)) 658 (cdr (cdr (cdr (cdr x))))) 659 660(defun last (list &optional n) 661 "Return the last link of LIST. Its car is the last element. 662If LIST is nil, return nil. 663If N is non-nil, return the Nth-to-last link of LIST. 664If N is bigger than the length of LIST, return LIST." 665 (declare (side-effect-free t)) 666 (if n 667 (and (>= n 0) 668 (let ((m (safe-length list))) 669 (if (< n m) (nthcdr (- m n) list) list))) 670 (and list 671 (nthcdr (1- (safe-length list)) list)))) 672 673(defun butlast (list &optional n) 674 "Return a copy of LIST with the last N elements removed. 675If N is omitted or nil, the last element is removed from the 676copy." 677 (declare (side-effect-free t)) 678 (if (and n (<= n 0)) list 679 (nbutlast (copy-sequence list) n))) 680 681(defun nbutlast (list &optional n) 682 "Modify LIST to remove the last N elements. 683If N is omitted or nil, remove the last element." 684 (let ((m (length list))) 685 (or n (setq n 1)) 686 (and (< n m) 687 (progn 688 (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil)) 689 list)))) 690 691;; The function's definition was moved to fns.c, 692;; but it's easier to set properties here. 693(put 'proper-list-p 'pure t) 694(put 'proper-list-p 'side-effect-free 'error-free) 695 696(defun delete-dups (list) 697 "Destructively remove `equal' duplicates from LIST. 698Store the result in LIST and return it. LIST must be a proper list. 699Of several `equal' occurrences of an element in LIST, the first 700one is kept. See `seq-uniq' for non-destructive operation." 701 (let ((l (length list))) 702 (if (> l 100) 703 (let ((hash (make-hash-table :test #'equal :size l)) 704 (tail list) retail) 705 (puthash (car list) t hash) 706 (while (setq retail (cdr tail)) 707 (let ((elt (car retail))) 708 (if (gethash elt hash) 709 (setcdr tail (cdr retail)) 710 (puthash elt t hash) 711 (setq tail retail))))) 712 (let ((tail list)) 713 (while tail 714 (setcdr tail (delete (car tail) (cdr tail))) 715 (setq tail (cdr tail)))))) 716 list) 717 718;; See https://lists.gnu.org/r/emacs-devel/2013-05/msg00204.html 719(defun delete-consecutive-dups (list &optional circular) 720 "Destructively remove `equal' consecutive duplicates from LIST. 721First and last elements are considered consecutive if CIRCULAR is 722non-nil." 723 (let ((tail list) last) 724 (while (cdr tail) 725 (if (equal (car tail) (cadr tail)) 726 (setcdr tail (cddr tail)) 727 (setq last tail 728 tail (cdr tail)))) 729 (if (and circular 730 last 731 (equal (car tail) (car list))) 732 (setcdr last nil))) 733 list) 734 735(defun number-sequence (from &optional to inc) 736 "Return a sequence of numbers from FROM to TO (both inclusive) as a list. 737INC is the increment used between numbers in the sequence and defaults to 1. 738So, the Nth element of the list is (+ FROM (* N INC)) where N counts from 739zero. TO is included only if there is an N for which TO = FROM + N * INC. 740If TO is nil or numerically equal to FROM, return (FROM). 741If INC is positive and TO is less than FROM, or INC is negative 742and TO is larger than FROM, return nil. 743If INC is zero and TO is neither nil nor numerically equal to 744FROM, signal an error. 745 746This function is primarily designed for integer arguments. 747Nevertheless, FROM, TO and INC can be integer or float. However, 748floating point arithmetic is inexact. For instance, depending on 749the machine, it may quite well happen that 750\(number-sequence 0.4 0.6 0.2) returns the one element list (0.4), 751whereas (number-sequence 0.4 0.8 0.2) returns a list with three 752elements. Thus, if some of the arguments are floats and one wants 753to make sure that TO is included, one may have to explicitly write 754TO as (+ FROM (* N INC)) or use a variable whose value was 755computed with this exact expression. Alternatively, you can, 756of course, also replace TO with a slightly larger value 757\(or a slightly more negative value if INC is negative)." 758 (if (or (not to) (= from to)) 759 (list from) 760 (or inc (setq inc 1)) 761 (when (zerop inc) (error "The increment can not be zero")) 762 (let (seq (n 0) (next from)) 763 (if (> inc 0) 764 (while (<= next to) 765 (setq seq (cons next seq) 766 n (1+ n) 767 next (+ from (* n inc)))) 768 (while (>= next to) 769 (setq seq (cons next seq) 770 n (1+ n) 771 next (+ from (* n inc))))) 772 (nreverse seq)))) 773 774(defun copy-tree (tree &optional vecp) 775 "Make a copy of TREE. 776If TREE is a cons cell, this recursively copies both its car and its cdr. 777Contrast to `copy-sequence', which copies only along the cdrs. With second 778argument VECP, this copies vectors as well as conses." 779 (if (consp tree) 780 (let (result) 781 (while (consp tree) 782 (let ((newcar (car tree))) 783 (if (or (consp (car tree)) (and vecp (vectorp (car tree)))) 784 (setq newcar (copy-tree (car tree) vecp))) 785 (push newcar result)) 786 (setq tree (cdr tree))) 787 (nconc (nreverse result) 788 (if (and vecp (vectorp tree)) (copy-tree tree vecp) tree))) 789 (if (and vecp (vectorp tree)) 790 (let ((i (length (setq tree (copy-sequence tree))))) 791 (while (>= (setq i (1- i)) 0) 792 (aset tree i (copy-tree (aref tree i) vecp))) 793 tree) 794 tree))) 795 796;;;; Various list-search functions. 797 798(defun assoc-default (key alist &optional test default) 799 "Find object KEY in a pseudo-alist ALIST. 800ALIST is a list of conses or objects. Each element 801 (or the element's car, if it is a cons) is compared with KEY by 802 calling TEST, with two arguments: (i) the element or its car, 803 and (ii) KEY. 804If that is non-nil, the element matches; then `assoc-default' 805 returns the element's cdr, if it is a cons, or DEFAULT if the 806 element is not a cons. 807 808If no element matches, the value is nil. 809If TEST is omitted or nil, `equal' is used." 810 (let (found (tail alist) value) 811 (while (and tail (not found)) 812 (let ((elt (car tail))) 813 (when (funcall (or test #'equal) (if (consp elt) (car elt) elt) key) 814 (setq found t value (if (consp elt) (cdr elt) default)))) 815 (setq tail (cdr tail))) 816 value)) 817 818(defun member-ignore-case (elt list) 819 "Like `member', but ignore differences in case and text representation. 820ELT must be a string. Upper-case and lower-case letters are treated as equal. 821Unibyte strings are converted to multibyte for comparison. 822Non-strings in LIST are ignored." 823 (declare (side-effect-free t)) 824 (while (and list 825 (not (and (stringp (car list)) 826 (eq t (compare-strings elt 0 nil (car list) 0 nil t))))) 827 (setq list (cdr list))) 828 list) 829 830(defun assoc-delete-all (key alist &optional test) 831 "Delete from ALIST all elements whose car is KEY. 832Compare keys with TEST. Defaults to `equal'. 833Return the modified alist. 834Elements of ALIST that are not conses are ignored." 835 (unless test (setq test #'equal)) 836 (while (and (consp (car alist)) 837 (funcall test (caar alist) key)) 838 (setq alist (cdr alist))) 839 (let ((tail alist) tail-cdr) 840 (while (setq tail-cdr (cdr tail)) 841 (if (and (consp (car tail-cdr)) 842 (funcall test (caar tail-cdr) key)) 843 (setcdr tail (cdr tail-cdr)) 844 (setq tail tail-cdr)))) 845 alist) 846 847(defun assq-delete-all (key alist) 848 "Delete from ALIST all elements whose car is `eq' to KEY. 849Return the modified alist. 850Elements of ALIST that are not conses are ignored." 851 (assoc-delete-all key alist #'eq)) 852 853(defun rassq-delete-all (value alist) 854 "Delete from ALIST all elements whose cdr is `eq' to VALUE. 855Return the modified alist. 856Elements of ALIST that are not conses are ignored." 857 (while (and (consp (car alist)) 858 (eq (cdr (car alist)) value)) 859 (setq alist (cdr alist))) 860 (let ((tail alist) tail-cdr) 861 (while (setq tail-cdr (cdr tail)) 862 (if (and (consp (car tail-cdr)) 863 (eq (cdr (car tail-cdr)) value)) 864 (setcdr tail (cdr tail-cdr)) 865 (setq tail tail-cdr)))) 866 alist) 867 868(defun alist-get (key alist &optional default remove testfn) 869 "Find the first element of ALIST whose `car' equals KEY and return its `cdr'. 870If KEY is not found in ALIST, return DEFAULT. 871Equality with KEY is tested by TESTFN, defaulting to `eq'. 872 873You can use `alist-get' in \"place expressions\"; i.e., as a 874generalized variable. Doing this will modify an existing 875association (more precisely, the first one if multiple exist), or 876add a new element to the beginning of ALIST, destructively 877modifying the list stored in ALIST. 878 879Example: 880 881 (setq foo \\='((a . 0))) 882 (setf (alist-get \\='a foo) 1 883 (alist-get \\='b foo) 2) 884 885 foo => ((b . 2) (a . 1)) 886 887 888When using it to set a value, optional argument REMOVE non-nil 889means to remove KEY from ALIST if the new value is `eql' to 890DEFAULT (more precisely the first found association will be 891deleted from the alist). 892 893Example: 894 895 (setq foo \\='((a . 1) (b . 2))) 896 (setf (alist-get \\='b foo nil \\='remove) nil) 897 898 foo => ((a . 1))" 899 (ignore remove) ;;Silence byte-compiler. 900 (let ((x (if (not testfn) 901 (assq key alist) 902 (assoc key alist testfn)))) 903 (if x (cdr x) default))) 904 905(defun remove (elt seq) 906 "Return a copy of SEQ with all occurrences of ELT removed. 907SEQ must be a list, vector, or string. The comparison is done with `equal'. 908Contrary to `delete', this does not use side-effects, and the argument 909SEQ is not modified." 910 (declare (side-effect-free t)) 911 (if (nlistp seq) 912 ;; If SEQ isn't a list, there's no need to copy SEQ because 913 ;; `delete' will return a new object. 914 (delete elt seq) 915 (delete elt (copy-sequence seq)))) 916 917(defun remq (elt list) 918 "Return LIST with all occurrences of ELT removed. 919The comparison is done with `eq'. Contrary to `delq', this does not use 920side-effects, and the argument LIST is not modified." 921 (declare (side-effect-free t)) 922 (while (and (eq elt (car list)) (setq list (cdr list)))) 923 (if (memq elt list) 924 (delq elt (copy-sequence list)) 925 list)) 926 927;;;; Keymap support. 928 929(defun kbd (keys) 930 "Convert KEYS to the internal Emacs key representation. 931KEYS should be a string in the format returned by commands such 932as `C-h k' (`describe-key'). 933 934This is the same format used for saving keyboard macros (see 935`edmacro-mode'). 936 937Here's some example key sequences: 938 939 \"f\" 940 \"C-c C-c\" 941 \"H-<left>\" 942 \"M-RET\" 943 \"C-M-<return>\" 944 945For an approximate inverse of this, see `key-description'." 946 (declare (pure t) (side-effect-free t)) 947 (let ((res (key-parse keys))) 948 (if (not (memq nil (mapcar (lambda (ch) 949 (and (numberp ch) 950 (<= 0 ch 127))) 951 res))) 952 ;; Return a string. 953 (concat (mapcar #'identity res)) 954 ;; Return a vector. 955 res))) 956 957(defun undefined () 958 "Beep to tell the user this binding is undefined." 959 (declare (completion ignore)) 960 (interactive) 961 (ding) 962 (if defining-kbd-macro 963 (error "%s is undefined" (key-description (this-single-command-keys))) 964 (message "%s is undefined" (key-description (this-single-command-keys)))) 965 (force-mode-line-update) 966 ;; If this is a down-mouse event, don't reset prefix-arg; 967 ;; pass it to the command run by the up event. 968 (setq prefix-arg 969 (when (memq 'down (event-modifiers last-command-event)) 970 current-prefix-arg))) 971 972;; Prevent the \{...} documentation construct 973;; from mentioning keys that run this command. 974(put 'undefined 'suppress-keymap t) 975 976(defun suppress-keymap (map &optional nodigits) 977 "Make MAP override all normally self-inserting keys to be undefined. 978Normally, as an exception, digits and minus-sign are set to make prefix args, 979but optional second arg NODIGITS non-nil treats them like other chars." 980 (define-key map [remap self-insert-command] #'undefined) 981 (or nodigits 982 (let (loop) 983 (define-key map "-" #'negative-argument) 984 ;; Make plain numbers do numeric args. 985 (setq loop ?0) 986 (while (<= loop ?9) 987 (define-key map (char-to-string loop) #'digit-argument) 988 (setq loop (1+ loop)))))) 989 990(defun make-composed-keymap (maps &optional parent) 991 "Construct a new keymap composed of MAPS and inheriting from PARENT. 992When looking up a key in the returned map, the key is looked in each 993keymap of MAPS in turn until a binding is found. 994If no binding is found in MAPS, the lookup continues in PARENT, if non-nil. 995As always with keymap inheritance, a nil binding in MAPS overrides 996any corresponding binding in PARENT, but it does not override corresponding 997bindings in other keymaps of MAPS. 998MAPS can be a list of keymaps or a single keymap. 999PARENT if non-nil should be a keymap." 1000 `(keymap 1001 ,@(if (keymapp maps) (list maps) maps) 1002 ,@parent)) 1003 1004(defun define-key-after (keymap key definition &optional after) 1005 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. 1006This is a legacy function; see `keymap-set-after' for the 1007recommended function to use instead. 1008 1009This is like `define-key' except that the binding for KEY is placed 1010just after the binding for the event AFTER, instead of at the beginning 1011of the map. Note that AFTER must be an event type (like KEY), NOT a command 1012\(like DEFINITION). 1013 1014If AFTER is t or omitted, the new binding goes at the end of the keymap. 1015AFTER should be a single event type--a symbol or a character, not a sequence. 1016 1017Bindings are always added before any inherited map. 1018 1019The order of bindings in a keymap matters only when it is used as 1020a menu, so this function is not useful for non-menu keymaps." 1021 (declare (indent defun)) 1022 (unless after (setq after t)) 1023 (or (keymapp keymap) 1024 (signal 'wrong-type-argument (list 'keymapp keymap))) 1025 (setq key 1026 (if (<= (length key) 1) (aref key 0) 1027 (setq keymap (lookup-key keymap 1028 (apply #'vector 1029 (butlast (mapcar #'identity key))))) 1030 (aref key (1- (length key))))) 1031 (let ((tail keymap) done inserted) 1032 (while (and (not done) tail) 1033 ;; Delete any earlier bindings for the same key. 1034 (if (eq (car-safe (car (cdr tail))) key) 1035 (setcdr tail (cdr (cdr tail)))) 1036 ;; If we hit an included map, go down that one. 1037 (if (keymapp (car tail)) (setq tail (car tail))) 1038 ;; When we reach AFTER's binding, insert the new binding after. 1039 ;; If we reach an inherited keymap, insert just before that. 1040 ;; If we reach the end of this keymap, insert at the end. 1041 (if (or (and (eq (car-safe (car tail)) after) 1042 (not (eq after t))) 1043 (eq (car (cdr tail)) 'keymap) 1044 (null (cdr tail))) 1045 (progn 1046 ;; Stop the scan only if we find a parent keymap. 1047 ;; Keep going past the inserted element 1048 ;; so we can delete any duplications that come later. 1049 (if (eq (car (cdr tail)) 'keymap) 1050 (setq done t)) 1051 ;; Don't insert more than once. 1052 (or inserted 1053 (setcdr tail (cons (cons key definition) (cdr tail)))) 1054 (setq inserted t))) 1055 (setq tail (cdr tail))))) 1056 1057(defun define-prefix-command (command &optional mapvar name) 1058 "Define COMMAND as a prefix command. COMMAND should be a symbol. 1059A new sparse keymap is stored as COMMAND's function definition and its 1060value. 1061This prepares COMMAND for use as a prefix key's binding. 1062If a second optional argument MAPVAR is given, it should be a symbol. 1063The map is then stored as MAPVAR's value instead of as COMMAND's 1064value; but COMMAND is still defined as a function. 1065The third optional argument NAME, if given, supplies a menu name 1066string for the map. This is required to use the keymap as a menu. 1067This function returns COMMAND." 1068 (let ((map (make-sparse-keymap name))) 1069 (fset command map) 1070 (set (or mapvar command) map) 1071 command)) 1072 1073(defun map-keymap-sorted (function keymap) 1074 "Implement `map-keymap' with sorting. 1075Don't call this function; it is for internal use only." 1076 (let (list) 1077 (map-keymap (lambda (a b) (push (cons a b) list)) 1078 keymap) 1079 (setq list (sort list 1080 (lambda (a b) 1081 (setq a (car a) b (car b)) 1082 (if (integerp a) 1083 (if (integerp b) (< a b) 1084 t) 1085 (if (integerp b) t 1086 ;; string< also accepts symbols. 1087 (string< a b)))))) 1088 (dolist (p list) 1089 (funcall function (car p) (cdr p))))) 1090 1091(defun keymap--menu-item-binding (val) 1092 "Return the binding part of a menu-item." 1093 (cond 1094 ((not (consp val)) val) ;Not a menu-item. 1095 ((eq 'menu-item (car val)) 1096 (let* ((binding (nth 2 val)) 1097 (plist (nthcdr 3 val)) 1098 (filter (plist-get plist :filter))) 1099 (if filter (funcall filter binding) 1100 binding))) 1101 ((and (consp (cdr val)) (stringp (cadr val))) 1102 (cddr val)) 1103 ((stringp (car val)) 1104 (cdr val)) 1105 (t val))) ;Not a menu-item either. 1106 1107(defun keymap--menu-item-with-binding (item binding) 1108 "Build a menu-item like ITEM but with its binding changed to BINDING." 1109 (cond 1110 ((not (consp item)) binding) ;Not a menu-item. 1111 ((eq 'menu-item (car item)) 1112 (setq item (copy-sequence item)) 1113 (let ((tail (nthcdr 2 item))) 1114 (setcar tail binding) 1115 ;; Remove any potential filter. 1116 (if (plist-get (cdr tail) :filter) 1117 (setcdr tail (plist-put (cdr tail) :filter nil)))) 1118 item) 1119 ((and (consp (cdr item)) (stringp (cadr item))) 1120 (cons (car item) (cons (cadr item) binding))) 1121 (t (cons (car item) binding)))) 1122 1123(defun keymap--merge-bindings (val1 val2) 1124 "Merge bindings VAL1 and VAL2." 1125 (let ((map1 (keymap--menu-item-binding val1)) 1126 (map2 (keymap--menu-item-binding val2))) 1127 (if (not (and (keymapp map1) (keymapp map2))) 1128 ;; There's nothing to merge: val1 takes precedence. 1129 val1 1130 (let ((map (list 'keymap map1 map2)) 1131 (item (if (keymapp val1) (if (keymapp val2) nil val2) val1))) 1132 (keymap--menu-item-with-binding item map))))) 1133 1134(defun keymap-canonicalize (map) 1135 "Return a simpler equivalent keymap. 1136This resolves inheritance and redefinitions. The returned keymap 1137should behave identically to a copy of KEYMAP w.r.t `lookup-key' 1138and use in active keymaps and menus. 1139Subkeymaps may be modified but are not canonicalized." 1140 ;; FIXME: Problem with the difference between a nil binding 1141 ;; that hides a binding in an inherited map and a nil binding that's ignored 1142 ;; to let some further binding visible. Currently a nil binding hides all. 1143 ;; FIXME: we may want to carefully (re)order elements in case they're 1144 ;; menu-entries. 1145 (let ((bindings ()) 1146 (ranges ()) 1147 (prompt (keymap-prompt map))) 1148 (while (keymapp map) 1149 (setq map (map-keymap ;; -internal 1150 (lambda (key item) 1151 (if (consp key) 1152 ;; Treat char-ranges specially. 1153 (push (cons key item) ranges) 1154 (push (cons key item) bindings))) 1155 map))) 1156 ;; Create the new map. 1157 (setq map (funcall (if ranges #'make-keymap #'make-sparse-keymap) prompt)) 1158 (dolist (binding ranges) 1159 ;; Treat char-ranges specially. FIXME: need to merge as well. 1160 (define-key map (vector (car binding)) (cdr binding))) 1161 ;; Process the bindings starting from the end. 1162 (dolist (binding (prog1 bindings (setq bindings ()))) 1163 (let* ((key (car binding)) 1164 (oldbind (assq key bindings))) 1165 (push (if (not oldbind) 1166 ;; The normal case: no duplicate bindings. 1167 binding 1168 ;; This is the second binding for this key. 1169 (setq bindings (delq oldbind bindings)) 1170 (cons key (keymap--merge-bindings (cdr binding) 1171 (cdr oldbind)))) 1172 bindings))) 1173 (nconc map bindings))) 1174 1175(put 'keyboard-translate-table 'char-table-extra-slots 0) 1176 1177(defun keyboard-translate (from to) 1178 "Translate character FROM to TO on the current terminal. 1179This is a legacy function; see `keymap-translate' for the 1180recommended function to use instead. 1181 1182This function creates a `keyboard-translate-table' if necessary 1183and then modifies one entry in it." 1184 (or (char-table-p keyboard-translate-table) 1185 (setq keyboard-translate-table 1186 (make-char-table 'keyboard-translate-table nil))) 1187 (aset keyboard-translate-table from to)) 1188 1189;;;; Key binding commands. 1190 1191(defun global-set-key (key command) 1192 "Give KEY a global binding as COMMAND. 1193This is a legacy function; see `keymap-global-set' for the 1194recommended function to use instead. 1195 1196COMMAND is the command definition to use; usually it is 1197a symbol naming an interactively-callable function. 1198KEY is a key sequence; noninteractively, it is a string or vector 1199of characters or event types, and non-ASCII characters with codes 1200above 127 (such as ISO Latin-1) can be included if you use a vector. 1201 1202Note that if KEY has a local binding in the current buffer, 1203that local binding will continue to shadow any global binding 1204that you make with this function." 1205 (interactive 1206 (let* ((menu-prompting nil) 1207 (key (read-key-sequence "Set key globally: " nil t))) 1208 (list key 1209 (read-command (format "Set key %s to command: " 1210 (key-description key)))))) 1211 (or (vectorp key) (stringp key) 1212 (signal 'wrong-type-argument (list 'arrayp key))) 1213 (define-key (current-global-map) key command)) 1214 1215(defun local-set-key (key command) 1216 "Give KEY a local binding as COMMAND. 1217This is a legacy function; see `keymap-local-set' for the 1218recommended function to use instead. 1219 1220COMMAND is the command definition to use; usually it is 1221a symbol naming an interactively-callable function. 1222KEY is a key sequence; noninteractively, it is a string or vector 1223of characters or event types, and non-ASCII characters with codes 1224above 127 (such as ISO Latin-1) can be included if you use a vector. 1225 1226The binding goes in the current buffer's local map, which in most 1227cases is shared with all other buffers in the same major mode." 1228 (interactive "KSet key locally: \nCSet key %s locally to command: ") 1229 (let ((map (current-local-map))) 1230 (or map 1231 (use-local-map (setq map (make-sparse-keymap)))) 1232 (or (vectorp key) (stringp key) 1233 (signal 'wrong-type-argument (list 'arrayp key))) 1234 (define-key map key command))) 1235 1236(defun global-unset-key (key) 1237 "Remove global binding of KEY. 1238This is a legacy function; see `keymap-global-unset' for the 1239recommended function to use instead. 1240 1241KEY is a string or vector representing a sequence of keystrokes." 1242 (interactive "kUnset key globally: ") 1243 (global-set-key key nil)) 1244 1245(defun local-unset-key (key) 1246 "Remove local binding of KEY. 1247This is a legacy function; see `keymap-local-unset' for the 1248recommended function to use instead. 1249 1250KEY is a string or vector representing a sequence of keystrokes." 1251 (interactive "kUnset key locally: ") 1252 (if (current-local-map) 1253 (local-set-key key nil)) 1254 nil) 1255 1256(defun local-key-binding (keys &optional accept-default) 1257 "Return the binding for command KEYS in current local keymap only. 1258This is a legacy function; see `keymap-local-binding' for the 1259recommended function to use instead. 1260 1261KEYS is a string or vector, a sequence of keystrokes. 1262The binding is probably a symbol with a function definition. 1263 1264If optional argument ACCEPT-DEFAULT is non-nil, recognize default 1265bindings; see the description of `lookup-key' for more details 1266about this." 1267 (let ((map (current-local-map))) 1268 (when map (lookup-key map keys accept-default)))) 1269 1270(defun global-key-binding (keys &optional accept-default) 1271 "Return the binding for command KEYS in current global keymap only. 1272This is a legacy function; see `keymap-global-binding' for the 1273recommended function to use instead. 1274 1275KEYS is a string or vector, a sequence of keystrokes. 1276The binding is probably a symbol with a function definition. 1277This function's return values are the same as those of `lookup-key' 1278\(which see). 1279 1280If optional argument ACCEPT-DEFAULT is non-nil, recognize default 1281bindings; see the description of `lookup-key' for more details 1282about this." 1283 (lookup-key (current-global-map) keys accept-default)) 1284 1285 1286;;;; substitute-key-definition and its subroutines. 1287 1288(defvar key-substitution-in-progress nil 1289 "Used internally by `substitute-key-definition'.") 1290 1291(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) 1292 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. 1293This is a legacy function; see `keymap-substitute' for the 1294recommended function to use instead. 1295 1296In other words, OLDDEF is replaced with NEWDEF wherever it appears. 1297Alternatively, if optional fourth argument OLDMAP is specified, we redefine 1298in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. 1299 1300If you don't specify OLDMAP, you can usually get the same results 1301in a cleaner way with command remapping, like this: 1302 (define-key KEYMAP [remap OLDDEF] NEWDEF) 1303\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" 1304 ;; Don't document PREFIX in the doc string because we don't want to 1305 ;; advertise it. It's meant for recursive calls only. Here's its 1306 ;; meaning 1307 1308 ;; If optional argument PREFIX is specified, it should be a key 1309 ;; prefix, a string. Redefined bindings will then be bound to the 1310 ;; original key, with PREFIX added at the front. 1311 (or prefix (setq prefix "")) 1312 (let* ((scan (or oldmap keymap)) 1313 (prefix1 (vconcat prefix [nil])) 1314 (key-substitution-in-progress 1315 (cons scan key-substitution-in-progress))) 1316 ;; Scan OLDMAP, finding each char or event-symbol that 1317 ;; has any definition, and act on it with hack-key. 1318 (map-keymap 1319 (lambda (char defn) 1320 (aset prefix1 (length prefix) char) 1321 (substitute-key-definition-key defn olddef newdef prefix1 keymap)) 1322 scan))) 1323 1324(defun substitute-key-definition-key (defn olddef newdef prefix keymap) 1325 (let (inner-def skipped menu-item) 1326 ;; Find the actual command name within the binding. 1327 (if (eq (car-safe defn) 'menu-item) 1328 (setq menu-item defn defn (nth 2 defn)) 1329 ;; Skip past menu-prompt. 1330 (while (stringp (car-safe defn)) 1331 (push (pop defn) skipped)) 1332 ;; Skip past cached key-equivalence data for menu items. 1333 (if (consp (car-safe defn)) 1334 (setq defn (cdr defn)))) 1335 (if (or (eq defn olddef) 1336 ;; Compare with equal if definition is a key sequence. 1337 ;; That is useful for operating on function-key-map. 1338 (and (or (stringp defn) (vectorp defn)) 1339 (equal defn olddef))) 1340 (define-key keymap prefix 1341 (if menu-item 1342 (let ((copy (copy-sequence menu-item))) 1343 (setcar (nthcdr 2 copy) newdef) 1344 copy) 1345 (nconc (nreverse skipped) newdef))) 1346 ;; Look past a symbol that names a keymap. 1347 (setq inner-def 1348 (or (indirect-function defn) defn)) 1349 ;; For nested keymaps, we use `inner-def' rather than `defn' so as to 1350 ;; avoid autoloading a keymap. This is mostly done to preserve the 1351 ;; original non-autoloading behavior of pre-map-keymap times. 1352 (if (and (keymapp inner-def) 1353 ;; Avoid recursively scanning 1354 ;; where KEYMAP does not have a submap. 1355 (let ((elt (lookup-key keymap prefix))) 1356 (or (null elt) (natnump elt) (keymapp elt))) 1357 ;; Avoid recursively rescanning keymap being scanned. 1358 (not (memq inner-def key-substitution-in-progress))) 1359 ;; If this one isn't being scanned already, scan it now. 1360 (substitute-key-definition olddef newdef keymap inner-def prefix))))) 1361 1362 1363;;;; The global keymap tree. 1364 1365(defvar esc-map 1366 (let ((map (make-keymap))) 1367 (define-key map "u" #'upcase-word) 1368 (define-key map "l" #'downcase-word) 1369 (define-key map "c" #'capitalize-word) 1370 (define-key map "x" #'execute-extended-command) 1371 (define-key map "X" #'execute-extended-command-for-buffer) 1372 map) 1373 "Default keymap for ESC (meta) commands. 1374The normal global definition of the character ESC indirects to this keymap.") 1375(fset 'ESC-prefix esc-map) 1376(make-obsolete 'ESC-prefix 'esc-map "28.1") 1377 1378(defvar ctl-x-4-map (make-sparse-keymap) 1379 "Keymap for subcommands of C-x 4.") 1380(defalias 'ctl-x-4-prefix ctl-x-4-map) 1381 1382(defvar ctl-x-5-map (make-sparse-keymap) 1383 "Keymap for frame commands.") 1384(defalias 'ctl-x-5-prefix ctl-x-5-map) 1385 1386(defvar tab-prefix-map (make-sparse-keymap) 1387 "Keymap for tab-bar related commands.") 1388 1389(defvar ctl-x-map 1390 (let ((map (make-keymap))) 1391 (define-key map "4" 'ctl-x-4-prefix) 1392 (define-key map "5" 'ctl-x-5-prefix) 1393 (define-key map "t" tab-prefix-map) 1394 1395 (define-key map "b" #'switch-to-buffer) 1396 (define-key map "k" #'kill-buffer) 1397 (define-key map "\C-u" #'upcase-region) (put 'upcase-region 'disabled t) 1398 (define-key map "\C-l" #'downcase-region) (put 'downcase-region 'disabled t) 1399 (define-key map "<" #'scroll-left) 1400 (define-key map ">" #'scroll-right) 1401 map) 1402 "Default keymap for C-x commands. 1403The normal global definition of the character C-x indirects to this keymap.") 1404(fset 'Control-X-prefix ctl-x-map) 1405(make-obsolete 'Control-X-prefix 'ctl-x-map "28.1") 1406 1407(defvar global-map 1408 (let ((map (make-keymap))) 1409 (define-key map "\C-[" 'ESC-prefix) 1410 (define-key map "\C-x" 'Control-X-prefix) 1411 1412 (define-key map "\C-i" #'self-insert-command) 1413 (let* ((vec1 (make-vector 1 nil)) 1414 (f (lambda (from to) 1415 (while (< from to) 1416 (aset vec1 0 from) 1417 (define-key map vec1 #'self-insert-command) 1418 (setq from (1+ from)))))) 1419 (funcall f #o040 #o0177) 1420 (when (eq system-type 'ms-dos) ;FIXME: Why? 1421 (funcall f #o0200 #o0240)) 1422 (funcall f #o0240 #o0400)) 1423 1424 (define-key map "\C-a" #'beginning-of-line) 1425 (define-key map "\C-b" #'backward-char) 1426 (define-key map "\C-e" #'end-of-line) 1427 (define-key map "\C-f" #'forward-char) 1428 1429 (define-key map "\C-z" #'suspend-emacs) ;FIXME: Re-bound later! 1430 (define-key map "\C-x\C-z" #'suspend-emacs) ;FIXME: Re-bound later! 1431 1432 (define-key map "\C-v" #'scroll-up-command) 1433 (define-key map "\M-v" #'scroll-down-command) 1434 (define-key map "\M-\C-v" #'scroll-other-window) 1435 1436 (define-key map "\M-\C-c" #'exit-recursive-edit) 1437 (define-key map "\C-]" #'abort-recursive-edit) 1438 map) 1439 "Default global keymap mapping Emacs keyboard input into commands. 1440The value is a keymap that is usually (but not necessarily) Emacs's 1441global map. 1442 1443See also `current-global-map'.") 1444(use-global-map global-map) 1445 1446 1447;;;; Event manipulation functions. 1448 1449(defconst listify-key-sequence-1 (logior 128 ?\M-\C-@)) 1450 1451(defun listify-key-sequence (key) 1452 "Convert a key sequence to a list of events." 1453 (if (vectorp key) 1454 (append key nil) 1455 (mapcar (lambda (c) 1456 (if (> c 127) 1457 (logxor c listify-key-sequence-1) 1458 c)) 1459 key))) 1460 1461(defun eventp (object) 1462 "Return non-nil if OBJECT is an input event or event object." 1463 (or (integerp object) 1464 (and (if (consp object) 1465 (setq object (car object)) 1466 object) 1467 (symbolp object) 1468 (not (keywordp object))))) 1469 1470(defun event-modifiers (event) 1471 "Return a list of symbols representing the modifier keys in event EVENT. 1472The elements of the list may include `meta', `control', 1473`shift', `hyper', `super', `alt', `click', `double', `triple', `drag', 1474and `down'. 1475EVENT may be an event or an event type. If EVENT is a symbol 1476that has never been used in an event that has been read as input 1477in the current Emacs session, then this function may fail to include 1478the `click' modifier." 1479 (let ((type event)) 1480 (if (listp type) 1481 (setq type (car type))) 1482 (if (symbolp type) 1483 ;; Don't read event-symbol-elements directly since we're not 1484 ;; sure the symbol has already been parsed. 1485 (cdr (internal-event-symbol-parse-modifiers type)) 1486 (let ((list nil) 1487 (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@ 1488 ?\H-\^@ ?\s-\^@ ?\A-\^@))))) 1489 (if (not (zerop (logand type ?\M-\^@))) 1490 (push 'meta list)) 1491 (if (or (not (zerop (logand type ?\C-\^@))) 1492 (< char 32)) 1493 (push 'control list)) 1494 (if (or (not (zerop (logand type ?\S-\^@))) 1495 (/= char (downcase char))) 1496 (push 'shift list)) 1497 (or (zerop (logand type ?\H-\^@)) 1498 (push 'hyper list)) 1499 (or (zerop (logand type ?\s-\^@)) 1500 (push 'super list)) 1501 (or (zerop (logand type ?\A-\^@)) 1502 (push 'alt list)) 1503 list)))) 1504 1505(defun event-basic-type (event) 1506 "Return the basic type of the given event (all modifiers removed). 1507The value is a printing character (not upper case) or a symbol. 1508EVENT may be an event or an event type. If EVENT is a symbol 1509that has never been used in an event that has been read as input 1510in the current Emacs session, then this function may return nil." 1511 (if (consp event) 1512 (setq event (car event))) 1513 (if (symbolp event) 1514 (car (get event 'event-symbol-elements)) 1515 (let* ((base (logand event (1- ?\A-\^@))) 1516 (uncontrolled (if (< base 32) (logior base 64) base))) 1517 ;; There are some numbers that are invalid characters and 1518 ;; cause `downcase' to get an error. 1519 (condition-case () 1520 (downcase uncontrolled) 1521 (error uncontrolled))))) 1522 1523(defsubst mouse-movement-p (object) 1524 "Return non-nil if OBJECT is a mouse movement event." 1525 (eq (car-safe object) 'mouse-movement)) 1526 1527(defun mouse-event-p (object) 1528 "Return non-nil if OBJECT is a mouse click event." 1529 ;; is this really correct? maybe remove mouse-movement? 1530 (memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement))) 1531 1532(defun event-start (event) 1533 "Return the starting position of EVENT. 1534EVENT should be a mouse click, drag, or key press event. If 1535EVENT is nil, the value of `posn-at-point' is used instead. 1536 1537The following accessor functions are used to access the elements 1538of the position: 1539 1540`posn-window': The window of the event end, or its frame if the 1541event end point belongs to no window. 1542`posn-area': A symbol identifying the area the event occurred in, 1543or nil if the event occurred in the text area. 1544`posn-point': The buffer position of the event. 1545`posn-x-y': The pixel-based coordinates of the event. 1546`posn-col-row': The estimated column and row corresponding to the 1547position of the event. 1548`posn-actual-col-row': The actual column and row corresponding to the 1549position of the event. 1550`posn-string': The string object of the event, which is either 1551nil or (STRING . POSITION)'. 1552`posn-image': The image object of the event, if any. 1553`posn-object': The image or string object of the event, if any. 1554`posn-timestamp': The time the event occurred, in milliseconds. 1555 1556For more information, see Info node `(elisp)Click Events'." 1557 (or (and (consp event) (nth 1 event)) 1558 ;; Use `window-point' for the case when the current buffer 1559 ;; is temporarily switched to some other buffer (bug#50256) 1560 (posn-at-point (window-point)) 1561 (list (selected-window) (window-point) '(0 . 0) 0))) 1562 1563(defun event-end (event) 1564 "Return the ending position of EVENT. 1565EVENT should be a click, drag, or key press event. 1566 1567See `event-start' for a description of the value returned." 1568 (or (and (consp event) (nth (if (consp (nth 2 event)) 2 1) event)) 1569 ;; Use `window-point' for the case when the current buffer 1570 ;; is temporarily switched to some other buffer (bug#50256) 1571 (posn-at-point (window-point)) 1572 (list (selected-window) (window-point) '(0 . 0) 0))) 1573 1574(defsubst event-click-count (event) 1575 "Return the multi-click count of EVENT, a click or drag event. 1576The return value is a positive integer." 1577 (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1)) 1578 1579(defsubst event-line-count (event) 1580 "Return the line count of EVENT, a mousewheel event. 1581The return value is a positive integer." 1582 (if (and (consp event) (integerp (nth 3 event))) (nth 3 event) 1)) 1583 1584;;;; Extracting fields of the positions in an event. 1585 1586(defun posnp (obj) 1587 "Return non-nil if OBJ appears to be a valid `posn' object specifying a window. 1588A `posn' object is returned from functions such as `event-start'. 1589If OBJ is a valid `posn' object, but specifies a frame rather 1590than a window, return nil." 1591 ;; FIXME: Correct the behavior of this function so that all valid 1592 ;; `posn' objects are recognized, after updating other code that 1593 ;; depends on its present behavior. 1594 (and (windowp (car-safe obj)) 1595 (atom (car-safe (setq obj (cdr obj)))) ;AREA-OR-POS. 1596 (integerp (car-safe (car-safe (setq obj (cdr obj))))) ;XOFFSET. 1597 (integerp (car-safe (cdr obj))))) ;TIMESTAMP. 1598 1599(defsubst posn-window (position) 1600 "Return the window in POSITION. 1601If POSITION is outside the frame where the event was initiated, 1602return that frame instead. POSITION should be a list of the form 1603returned by the `event-start' and `event-end' functions." 1604 (nth 0 position)) 1605 1606(defsubst posn-area (position) 1607 "Return the window area recorded in POSITION, or nil for the text area. 1608POSITION should be a list of the form returned by the `event-start' 1609and `event-end' functions." 1610 (let ((area (if (consp (nth 1 position)) 1611 (car (nth 1 position)) 1612 (nth 1 position)))) 1613 (and (symbolp area) area))) 1614 1615(defun posn-point (position) 1616 "Return the buffer location in POSITION. 1617POSITION should be a list of the form returned by the `event-start' 1618and `event-end' functions. 1619Returns nil if POSITION does not correspond to any buffer location (e.g. 1620a click on a scroll bar)." 1621 (or (nth 5 position) 1622 (let ((pt (nth 1 position))) 1623 (or (car-safe pt) 1624 ;; Apparently this can also be `vertical-scroll-bar' (bug#13979). 1625 (if (integerp pt) pt))))) 1626 1627(defun posn-set-point (position) 1628 "Move point to POSITION. 1629Select the corresponding window as well." 1630 (if (framep (posn-window position)) 1631 (progn 1632 (unless (windowp (frame-selected-window (posn-window position))) 1633 (error "Position not in text area of window")) 1634 (select-window (frame-selected-window (posn-window position)))) 1635 (unless (windowp (posn-window position)) 1636 (error "Position not in text area of window")) 1637 (select-window (posn-window position))) 1638 (if (numberp (posn-point position)) 1639 (goto-char (posn-point position)))) 1640 1641(defsubst posn-x-y (position) 1642 "Return the x and y coordinates in POSITION. 1643The return value has the form (X . Y), where X and Y are given in 1644pixels. POSITION should be a list of the form returned by 1645`event-start' and `event-end'." 1646 (nth 2 position)) 1647 1648(declare-function scroll-bar-scale "scroll-bar" (num-denom whole)) 1649 1650(defun posn-col-row (position) 1651 "Return the nominal column and row in POSITION, measured in characters. 1652The column and row values are approximations calculated from the x 1653and y coordinates in POSITION and the frame's default character width 1654and default line height, including spacing. 1655For a scroll-bar event, the result column is 0, and the row 1656corresponds to the vertical position of the click in the scroll bar. 1657POSITION should be a list of the form returned by the `event-start' 1658and `event-end' functions." 1659 (let* ((pair (posn-x-y position)) 1660 (frame-or-window (posn-window position)) 1661 (frame (if (framep frame-or-window) 1662 frame-or-window 1663 (window-frame frame-or-window))) 1664 (window (when (windowp frame-or-window) frame-or-window)) 1665 (area (posn-area position))) 1666 (cond 1667 ((null frame-or-window) 1668 '(0 . 0)) 1669 ((eq area 'vertical-scroll-bar) 1670 (cons 0 (scroll-bar-scale pair (1- (window-height window))))) 1671 ((eq area 'horizontal-scroll-bar) 1672 (cons (scroll-bar-scale pair (window-width window)) 0)) 1673 (t 1674 ;; FIXME: This should take line-spacing properties on 1675 ;; newlines into account. 1676 (let* ((spacing (when (display-graphic-p frame) 1677 (or (with-current-buffer 1678 (window-buffer (frame-selected-window frame)) 1679 line-spacing) 1680 (frame-parameter frame 'line-spacing))))) 1681 (cond ((floatp spacing) 1682 (setq spacing (truncate (* spacing 1683 (frame-char-height frame))))) 1684 ((null spacing) 1685 (setq spacing 0))) 1686 (cons (/ (car pair) (frame-char-width frame)) 1687 (/ (cdr pair) (+ (frame-char-height frame) spacing)))))))) 1688 1689(defun posn-actual-col-row (position) 1690 "Return the window row number in POSITION and character number in that row. 1691 1692Return nil if POSITION does not contain the actual position; in that case 1693`posn-col-row' can be used to get approximate values. 1694POSITION should be a list of the form returned by the `event-start' 1695and `event-end' functions. 1696 1697This function does not account for the width on display, like the 1698number of visual columns taken by a TAB or image. If you need 1699the coordinates of POSITION in character units, you should use 1700`posn-col-row', not this function." 1701 (nth 6 position)) 1702 1703(defsubst posn-timestamp (position) 1704 "Return the timestamp of POSITION. 1705POSITION should be a list of the form returned by the `event-start' 1706and `event-end' functions." 1707 (nth 3 position)) 1708 1709(defun posn-string (position) 1710 "Return the string object of POSITION. 1711Value is a cons (STRING . STRING-POS), or nil if not a string. 1712POSITION should be a list of the form returned by the `event-start' 1713and `event-end' functions." 1714 (let ((x (nth 4 position))) 1715 ;; Apparently this can also be `handle' or `below-handle' (bug#13979). 1716 (when (consp x) x))) 1717 1718(defsubst posn-image (position) 1719 "Return the image object of POSITION. 1720Value is a list (image ...), or nil if not an image. 1721POSITION should be a list of the form returned by the `event-start' 1722and `event-end' functions." 1723 (nth 7 position)) 1724 1725(defsubst posn-object (position) 1726 "Return the object (image or string) of POSITION. 1727Value is a list (image ...) for an image object, a cons cell 1728\(STRING . STRING-POS) for a string object, and nil for a buffer position. 1729POSITION should be a list of the form returned by the `event-start' 1730and `event-end' functions." 1731 (or (posn-image position) (posn-string position))) 1732 1733(defsubst posn-object-x-y (position) 1734 "Return the x and y coordinates relative to the object of POSITION. 1735The return value has the form (DX . DY), where DX and DY are 1736given in pixels. POSITION should be a list of the form returned 1737by `event-start' and `event-end'." 1738 (nth 8 position)) 1739 1740(defsubst posn-object-width-height (position) 1741 "Return the pixel width and height of the object of POSITION. 1742The return value has the form (WIDTH . HEIGHT). POSITION should 1743be a list of the form returned by `event-start' and `event-end'." 1744 (nth 9 position)) 1745 1746(defun values--store-value (value) 1747 "Store VALUE in the obsolete `values' variable." 1748 (with-suppressed-warnings ((obsolete values)) 1749 (push value values)) 1750 value) 1751 1752 1753;;;; Obsolescent names for functions. 1754 1755(make-obsolete 'buffer-has-markers-at nil "24.3") 1756 1757(make-obsolete 'invocation-directory "use the variable of the same name." 1758 "27.1") 1759(make-obsolete 'invocation-name "use the variable of the same name." "27.1") 1760 1761;; We used to declare string-to-unibyte obsolete, but it is a valid 1762;; way of getting a unibyte string that can be indexed by bytes, when 1763;; the original string has raw bytes in their internal multibyte 1764;; representation. This can be useful when one needs to examine 1765;; individual bytes at known offsets from the string beginning. 1766;; (make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") 1767;; string-to-multibyte is also sometimes useful (and there's no good 1768;; general replacement for it), so it's also been revived in Emacs 27.1. 1769;; (make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1") 1770;; bug#23850 1771(make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1") 1772(make-obsolete 'string-make-unibyte "use `encode-coding-string'." "26.1") 1773(make-obsolete 'string-as-multibyte "use `decode-coding-string'." "26.1") 1774(make-obsolete 'string-make-multibyte "use `decode-coding-string'." "26.1") 1775 1776(defun log10 (x) 1777 "Return (log X 10), the log base 10 of X." 1778 (declare (obsolete log "24.4")) 1779 (log x 10)) 1780 1781(set-advertised-calling-convention 1782 'all-completions '(string collection &optional predicate) "23.1") 1783(set-advertised-calling-convention 'unintern '(name obarray) "23.3") 1784(set-advertised-calling-convention 'indirect-function '(object) "25.1") 1785(set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3") 1786(set-advertised-calling-convention 'libxml-parse-xml-region '(start end &optional base-url) "27.1") 1787(set-advertised-calling-convention 'libxml-parse-html-region '(start end &optional base-url) "27.1") 1788 1789;;;; Obsolescence declarations for variables, and aliases. 1790 1791(make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1") 1792(make-obsolete-variable 'deferred-action-list 'post-command-hook "24.1") 1793(make-obsolete-variable 'deferred-action-function 'post-command-hook "24.1") 1794(make-obsolete-variable 'redisplay-dont-pause nil "24.5") 1795(make-obsolete 'window-redisplay-end-trigger nil "23.1") 1796(make-obsolete 'set-window-redisplay-end-trigger nil "23.1") 1797(make-obsolete-variable 'operating-system-release nil "28.1") 1798(make-obsolete-variable 'inhibit-changing-match-data 'save-match-data "29.1") 1799 1800(make-obsolete 'run-window-configuration-change-hook nil "27.1") 1801 1802(make-obsolete-variable 'command-debug-status 1803 "expect it to be removed in a future version." "25.2") 1804 1805;; This was introduced in 21.4 for pre-unicode unification. That 1806;; usage was rendered obsolete in 23.1, which uses Unicode internally. 1807;; Other uses are possible, so this variable is not _really_ obsolete, 1808;; but Stefan insists to mark it so. 1809(make-obsolete-variable 'translation-table-for-input nil "23.1") 1810 1811(make-obsolete-variable 'x-gtk-use-window-move nil "26.1") 1812 1813(defvaralias 'messages-buffer-max-lines 'message-log-max) 1814(define-obsolete-variable-alias 'inhibit-nul-byte-detection 1815 'inhibit-null-byte-detection "28.1") 1816(make-obsolete-variable 'load-dangerous-libraries 1817 "no longer used." "27.1") 1818 1819(defvar inhibit--record-char nil 1820 "Obsolete variable. 1821This was used internally by quail.el and keyboard.c in Emacs 27. 1822It does nothing in Emacs 28.") 1823(make-obsolete-variable 'inhibit--record-char nil "28.1") 1824 1825;; We can't actually make `values' obsolete, because that will result 1826;; in warnings when using `values' in let-bindings. 1827;;(make-obsolete-variable 'values "no longer used" "28.1") 1828 1829 1830;;;; Alternate names for functions - these are not being phased out. 1831 1832(defalias 'send-string #'process-send-string) 1833(defalias 'send-region #'process-send-region) 1834(defalias 'string= #'string-equal) 1835(defalias 'string< #'string-lessp) 1836(defalias 'string> #'string-greaterp) 1837(defalias 'move-marker #'set-marker) 1838(defalias 'rplaca #'setcar) 1839(defalias 'rplacd #'setcdr) 1840(defalias 'beep #'ding) ;preserve lingual purity 1841(defalias 'indent-to-column #'indent-to) 1842(defalias 'backward-delete-char #'delete-backward-char) 1843(defalias 'search-forward-regexp (symbol-function 're-search-forward)) 1844(defalias 'search-backward-regexp (symbol-function 're-search-backward)) 1845(defalias 'int-to-string #'number-to-string) 1846(defalias 'store-match-data #'set-match-data) 1847(defalias 'chmod #'set-file-modes) 1848(defalias 'mkdir #'make-directory) 1849;; These are the XEmacs names: 1850(defalias 'point-at-eol #'line-end-position) 1851(defalias 'point-at-bol #'line-beginning-position) 1852 1853(define-obsolete-function-alias 'user-original-login-name 1854 #'user-login-name "28.1") 1855 1856 1857;;;; Hook manipulation functions. 1858 1859(defun add-hook (hook function &optional depth local) 1860 ;; Note: the -100..100 depth range is arbitrary and was chosen to match the 1861 ;; range used in add-function. 1862 "Add to the value of HOOK the function FUNCTION. 1863FUNCTION is not added if already present. 1864 1865The place where the function is added depends on the DEPTH 1866parameter. DEPTH defaults to 0. By convention, it should be 1867a number between -100 and 100 where 100 means that the function 1868should be at the very end of the list, whereas -100 means that 1869the function should always come first. 1870Since nothing is \"always\" true, don't use 100 nor -100. 1871When two functions have the same depth, the new one gets added after the 1872old one if depth is strictly positive and before otherwise. 1873 1874For backward compatibility reasons, a symbol other than nil is 1875interpreted as a DEPTH of 90. 1876 1877The optional fourth argument, LOCAL, if non-nil, says to modify 1878the hook's buffer-local value rather than its global value. 1879This makes the hook buffer-local, and it makes t a member of the 1880buffer-local value. That acts as a flag to run the hook 1881functions of the global value as well as in the local value. 1882 1883HOOK should be a symbol. If HOOK is void, it is first set to 1884nil. If HOOK's value is a single function, it is changed to a 1885list of functions. 1886 1887FUNCTION may be any valid function, but it's recommended to use a 1888function symbol and not a lambda form. Using a symbol will 1889ensure that the function is not re-added if the function is 1890edited, and using lambda forms may also have a negative 1891performance impact when running `add-hook' and `remove-hook'." 1892 (or (boundp hook) (set hook nil)) 1893 (or (default-boundp hook) (set-default hook nil)) 1894 (unless (numberp depth) (setq depth (if depth 90 0))) 1895 (if local (unless (local-variable-if-set-p hook) 1896 (set (make-local-variable hook) (list t))) 1897 ;; Detect the case where make-local-variable was used on a hook 1898 ;; and do what we used to do. 1899 (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook))) 1900 (setq local t))) 1901 (let ((hook-value (if local (symbol-value hook) (default-value hook)))) 1902 ;; If the hook value is a single function, turn it into a list. 1903 (when (or (not (listp hook-value)) (functionp hook-value)) 1904 (setq hook-value (list hook-value))) 1905 ;; Do the actual addition if necessary 1906 (unless (member function hook-value) 1907 (when (stringp function) ;FIXME: Why? 1908 (setq function (purecopy function))) 1909 ;; All those `equal' tests performed between functions can end up being 1910 ;; costly since those functions may be large recursive and even cyclic 1911 ;; structures, so we index `hook--depth-alist' with `eq'. (bug#46326) 1912 (when (or (get hook 'hook--depth-alist) (not (zerop depth))) 1913 ;; Note: The main purpose of the above `when' test is to avoid running 1914 ;; this `setf' before `gv' is loaded during bootstrap. 1915 (setf (alist-get function (get hook 'hook--depth-alist) 0) depth)) 1916 (setq hook-value 1917 (if (< 0 depth) 1918 (append hook-value (list function)) 1919 (cons function hook-value))) 1920 (let ((depth-alist (get hook 'hook--depth-alist))) 1921 (when depth-alist 1922 (setq hook-value 1923 (sort (if (< 0 depth) hook-value (copy-sequence hook-value)) 1924 (lambda (f1 f2) 1925 (< (alist-get f1 depth-alist 0 nil #'eq) 1926 (alist-get f2 depth-alist 0 nil #'eq)))))))) 1927 ;; Set the actual variable 1928 (if local 1929 (progn 1930 ;; If HOOK isn't a permanent local, 1931 ;; but FUNCTION wants to survive a change of modes, 1932 ;; mark HOOK as partially permanent. 1933 (and (symbolp function) 1934 (get function 'permanent-local-hook) 1935 (not (get hook 'permanent-local)) 1936 (put hook 'permanent-local 'permanent-local-hook)) 1937 (set hook hook-value)) 1938 (set-default hook hook-value)))) 1939 1940(defun remove-hook (hook function &optional local) 1941 "Remove from the value of HOOK the function FUNCTION. 1942HOOK should be a symbol, and FUNCTION may be any valid function. If 1943FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the 1944list of hooks to run in HOOK, then nothing is done. See `add-hook'. 1945 1946The optional third argument, LOCAL, if non-nil, says to modify 1947the hook's buffer-local value rather than its default value. 1948 1949Interactively, prompt for the various arguments (skipping local 1950unless HOOK has both local and global functions). If multiple 1951functions have the same representation under `princ', the first 1952one will be removed." 1953 (interactive 1954 (let* ((default (and (symbolp (variable-at-point)) 1955 (symbol-name (variable-at-point)))) 1956 (hook (intern (completing-read 1957 (format-prompt "Hook variable" default) 1958 obarray #'boundp t nil nil default))) 1959 (local 1960 (and 1961 (local-variable-p hook) 1962 (symbol-value hook) 1963 ;; No need to prompt if there's nothing global 1964 (or (not (default-value hook)) 1965 (y-or-n-p (format "%s has a buffer-local binding, use that? " 1966 hook))))) 1967 (fn-alist (mapcar 1968 (lambda (x) (cons (with-output-to-string (prin1 x)) x)) 1969 (if local (symbol-value hook) (default-value hook)))) 1970 (function (alist-get (completing-read 1971 (format "%s hook to remove: " 1972 (if local "Buffer-local" "Global")) 1973 fn-alist 1974 nil t) 1975 fn-alist nil nil #'string=))) 1976 (list hook function local))) 1977 (or (boundp hook) (set hook nil)) 1978 (or (default-boundp hook) (set-default hook nil)) 1979 ;; Do nothing if LOCAL is t but this hook has no local binding. 1980 (unless (and local (not (local-variable-p hook))) 1981 ;; Detect the case where make-local-variable was used on a hook 1982 ;; and do what we used to do. 1983 (when (and (local-variable-p hook) 1984 (not (and (consp (symbol-value hook)) 1985 (memq t (symbol-value hook))))) 1986 (setq local t)) 1987 (let ((hook-value (if local (symbol-value hook) (default-value hook))) 1988 (old-fun nil)) 1989 ;; Remove the function, for both the list and the non-list cases. 1990 (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda)) 1991 (when (equal hook-value function) 1992 (setq old-fun hook-value) 1993 (setq hook-value nil)) 1994 (when (setq old-fun (car (member function hook-value))) 1995 (setq hook-value (remq old-fun hook-value)))) 1996 (when old-fun 1997 ;; Remove auxiliary depth info to avoid leaks (bug#46414) 1998 ;; and to avoid the list growing too long. 1999 (let* ((depths (get hook 'hook--depth-alist)) 2000 (di (assq old-fun depths))) 2001 (when di (put hook 'hook--depth-alist (delq di depths))))) 2002 ;; If the function is on the global hook, we need to shadow it locally 2003 ;;(when (and local (member function (default-value hook)) 2004 ;; (not (member (cons 'not function) hook-value))) 2005 ;; (push (cons 'not function) hook-value)) 2006 ;; Set the actual variable 2007 (if (not local) 2008 (set-default hook hook-value) 2009 (if (equal hook-value '(t)) 2010 (kill-local-variable hook) 2011 (set hook hook-value)))))) 2012 2013(defmacro letrec (binders &rest body) 2014 "Bind variables according to BINDERS then eval BODY. 2015The value of the last form in BODY is returned. 2016Each element of BINDERS is a list (SYMBOL VALUEFORM) that binds 2017SYMBOL to the value of VALUEFORM. 2018 2019The main difference between this macro and `let'/`let*' is that 2020all symbols are bound before any of the VALUEFORMs are evalled." 2021 ;; Useful only in lexical-binding mode. 2022 ;; As a special-form, we could implement it more efficiently (and cleanly, 2023 ;; making the vars actually unbound during evaluation of the binders). 2024 (declare (debug let) (indent 1)) 2025 ;; Use plain `let*' for the non-recursive definitions. 2026 ;; This only handles the case where the first few definitions are not 2027 ;; recursive. Nothing as fancy as an SCC analysis. 2028 (let ((seqbinds nil)) 2029 ;; Our args haven't yet been macro-expanded, so `macroexp--fgrep' 2030 ;; may fail to see references that will be introduced later by 2031 ;; macroexpansion. We could call `macroexpand-all' to avoid that, 2032 ;; but in order to avoid that, we instead check to see if the binders 2033 ;; appear in the macroexp environment, since that's how references can be 2034 ;; introduced later on. 2035 (unless (macroexp--fgrep binders macroexpand-all-environment) 2036 (while (and binders 2037 (null (macroexp--fgrep binders (nth 1 (car binders))))) 2038 (push (pop binders) seqbinds))) 2039 (let ((nbody (if (null binders) 2040 (macroexp-progn body) 2041 `(let ,(mapcar #'car binders) 2042 ,@(mapcar (lambda (binder) `(setq ,@binder)) binders) 2043 ,@body)))) 2044 (cond 2045 ;; All bindings are recursive. 2046 ((null seqbinds) nbody) 2047 ;; Special case for trivial uses. 2048 ((and (symbolp nbody) (null (cdr seqbinds)) (eq nbody (caar seqbinds))) 2049 (nth 1 (car seqbinds))) 2050 ;; General case. 2051 (t `(let* ,(nreverse seqbinds) ,nbody)))))) 2052 2053(defmacro dlet (binders &rest body) 2054 "Like `let' but using dynamic scoping." 2055 (declare (indent 1) (debug let)) 2056 ;; (defvar FOO) only affects the current scope, but in order for 2057 ;; this not to affect code after the main `let' we need to create a new scope, 2058 ;; which is what the surrounding `let' is for. 2059 ;; FIXME: (let () ...) currently doesn't actually create a new scope, 2060 ;; which is why we use (let (_) ...). 2061 `(let (_) 2062 ,@(mapcar (lambda (binder) 2063 `(defvar ,(if (consp binder) (car binder) binder))) 2064 binders) 2065 (let ,binders ,@body))) 2066 2067 2068(defmacro with-wrapper-hook (hook args &rest body) 2069 "Run BODY, using wrapper functions from HOOK with additional ARGS. 2070HOOK is an abnormal hook. Each hook function in HOOK \"wraps\" 2071around the preceding ones, like a set of nested `around' advices. 2072 2073Each hook function should accept an argument list consisting of a 2074function FUN, followed by the additional arguments in ARGS. 2075 2076The first hook function in HOOK is passed a FUN that, if it is called 2077with arguments ARGS, performs BODY (i.e., the default operation). 2078The FUN passed to each successive hook function is defined based 2079on the preceding hook functions; if called with arguments ARGS, 2080it does what the `with-wrapper-hook' call would do if the 2081preceding hook functions were the only ones present in HOOK. 2082 2083Each hook function may call its FUN argument as many times as it wishes, 2084including never. In that case, such a hook function acts to replace 2085the default definition altogether, and any preceding hook functions. 2086Of course, a subsequent hook function may do the same thing. 2087 2088Each hook function definition is used to construct the FUN passed 2089to the next hook function, if any. The last (or \"outermost\") 2090FUN is then called once." 2091 (declare (indent 2) (debug (form sexp body)) 2092 (obsolete "use a <foo>-function variable modified by `add-function'." 2093 "24.4")) 2094 `(subr--with-wrapper-hook-no-warnings ,hook ,args ,@body)) 2095 2096(defmacro subr--with-wrapper-hook-no-warnings (hook args &rest body) 2097 "Like (with-wrapper-hook HOOK ARGS BODY), but without warnings." 2098 (declare (debug (form sexp def-body))) 2099 ;; We need those two gensyms because CL's lexical scoping is not available 2100 ;; for function arguments :-( 2101 (let ((funs (make-symbol "funs")) 2102 (global (make-symbol "global")) 2103 (argssym (make-symbol "args")) 2104 (runrestofhook (make-symbol "runrestofhook"))) 2105 ;; Since the hook is a wrapper, the loop has to be done via 2106 ;; recursion: a given hook function will call its parameter in order to 2107 ;; continue looping. 2108 `(letrec ((,runrestofhook 2109 (lambda (,funs ,global ,argssym) 2110 ;; `funs' holds the functions left on the hook and `global' 2111 ;; holds the functions left on the global part of the hook 2112 ;; (in case the hook is local). 2113 (if (consp ,funs) 2114 (if (eq t (car ,funs)) 2115 (funcall ,runrestofhook 2116 (append ,global (cdr ,funs)) nil ,argssym) 2117 (apply (car ,funs) 2118 (apply-partially 2119 (lambda (,funs ,global &rest ,argssym) 2120 (funcall ,runrestofhook ,funs ,global ,argssym)) 2121 (cdr ,funs) ,global) 2122 ,argssym)) 2123 ;; Once there are no more functions on the hook, run 2124 ;; the original body. 2125 (apply (lambda ,args ,@body) ,argssym))))) 2126 (funcall ,runrestofhook ,hook 2127 ;; The global part of the hook, if any. 2128 ,(if (symbolp hook) 2129 `(if (local-variable-p ',hook) 2130 (default-value ',hook))) 2131 (list ,@args))))) 2132 2133(defun add-to-list (list-var element &optional append compare-fn) 2134 "Add ELEMENT to the value of LIST-VAR if it isn't there yet. 2135The test for presence of ELEMENT is done with `equal', or with 2136COMPARE-FN if that's non-nil. 2137If ELEMENT is added, it is added at the beginning of the list, 2138unless the optional argument APPEND is non-nil, in which case 2139ELEMENT is added at the end. 2140LIST-VAR should not refer to a lexical variable. 2141 2142The return value is the new value of LIST-VAR. 2143 2144This is handy to add some elements to configuration variables, 2145but please do not abuse it in Elisp code, where you are usually 2146better off using `push' or `cl-pushnew'. 2147 2148If you want to use `add-to-list' on a variable that is not 2149defined until a certain package is loaded, you should put the 2150call to `add-to-list' into a hook function that will be run only 2151after loading the package. `eval-after-load' provides one way to 2152do this. In some cases other hooks, such as major mode hooks, 2153can do the job." 2154 (declare 2155 (compiler-macro 2156 (lambda (exp) 2157 ;; FIXME: Something like this could be used for `set' as well. 2158 (if (or (not (eq 'quote (car-safe list-var))) 2159 (special-variable-p (cadr list-var)) 2160 (not (macroexp-const-p append))) 2161 exp 2162 (let* ((sym (cadr list-var)) 2163 (append (eval append)) 2164 (msg (format-message 2165 "`add-to-list' can't use lexical var `%s'; use `push' or `cl-pushnew'" 2166 sym)) 2167 ;; Big ugly hack, so we output a warning only during 2168 ;; byte-compilation, and so we can use 2169 ;; byte-compile-not-lexical-var-p to silence the warning 2170 ;; when a defvar has been seen but not yet executed. 2171 (warnfun (lambda () 2172 ;; FIXME: We should also emit a warning for let-bound 2173 ;; variables with dynamic binding. 2174 (when (assq sym byte-compile--lexical-environment) 2175 (byte-compile-report-error msg :fill)))) 2176 (code 2177 (macroexp-let2 macroexp-copyable-p x element 2178 `(if ,(if compare-fn 2179 (progn 2180 (require 'cl-lib) 2181 `(cl-member ,x ,sym :test ,compare-fn)) 2182 ;; For bootstrapping reasons, don't rely on 2183 ;; cl--compiler-macro-member for the base case. 2184 `(member ,x ,sym)) 2185 ,sym 2186 ,(if append 2187 `(setq ,sym (append ,sym (list ,x))) 2188 `(push ,x ,sym)))))) 2189 (if (not (macroexp-compiling-p)) 2190 code 2191 `(progn 2192 (macroexp--funcall-if-compiled ',warnfun) 2193 ,code))))))) 2194 (if (cond 2195 ((null compare-fn) 2196 (member element (symbol-value list-var))) 2197 ((eq compare-fn #'eq) 2198 (memq element (symbol-value list-var))) 2199 ((eq compare-fn #'eql) 2200 (memql element (symbol-value list-var))) 2201 (t 2202 (let ((lst (symbol-value list-var))) 2203 (while (and lst 2204 (not (funcall compare-fn element (car lst)))) 2205 (setq lst (cdr lst))) 2206 lst))) 2207 (symbol-value list-var) 2208 (set list-var 2209 (if append 2210 (append (symbol-value list-var) (list element)) 2211 (cons element (symbol-value list-var)))))) 2212 2213 2214(defun add-to-ordered-list (list-var element &optional order) 2215 "Add ELEMENT to the value of LIST-VAR if it isn't there yet. 2216The test for presence of ELEMENT is done with `eq'. 2217 2218The value of LIST-VAR is kept ordered based on the ORDER 2219parameter. 2220 2221If the third optional argument ORDER is a number (integer or 2222float), set the element's list order to the given value. If 2223ORDER is nil or omitted, do not change the numeric order of 2224ELEMENT. If ORDER has any other value, remove the numeric order 2225of ELEMENT if it has one. 2226 2227The list order for each element is stored in LIST-VAR's 2228`list-order' property. 2229LIST-VAR cannot refer to a lexical variable. 2230 2231The return value is the new value of LIST-VAR." 2232 (let ((ordering (get list-var 'list-order))) 2233 (unless ordering 2234 (put list-var 'list-order 2235 (setq ordering (make-hash-table :weakness 'key :test 'eq)))) 2236 (when order 2237 (puthash element (and (numberp order) order) ordering)) 2238 (unless (memq element (symbol-value list-var)) 2239 (set list-var (cons element (symbol-value list-var)))) 2240 (set list-var (sort (symbol-value list-var) 2241 (lambda (a b) 2242 (let ((oa (gethash a ordering)) 2243 (ob (gethash b ordering))) 2244 (if (and oa ob) 2245 (< oa ob) 2246 oa))))))) 2247 2248(defun add-to-history (history-var newelt &optional maxelt keep-all) 2249 "Add NEWELT to the history list stored in the variable HISTORY-VAR. 2250Return the new history list. 2251If MAXELT is non-nil, it specifies the maximum length of the history. 2252Otherwise, the maximum history length is the value of the `history-length' 2253property on symbol HISTORY-VAR, if set, or the value of the `history-length' 2254variable. The possible values of maximum length have the same meaning as 2255the values of `history-length'. 2256Remove duplicates of NEWELT if `history-delete-duplicates' is non-nil. 2257If optional fourth arg KEEP-ALL is non-nil, add NEWELT to history even 2258if it is empty or duplicates the most recent entry in the history. 2259HISTORY-VAR cannot refer to a lexical variable." 2260 (unless maxelt 2261 (setq maxelt (or (get history-var 'history-length) 2262 history-length))) 2263 (let ((history (symbol-value history-var)) 2264 tail) 2265 (when (and (listp history) 2266 (or keep-all 2267 (not (stringp newelt)) 2268 (> (length newelt) 0)) 2269 (or keep-all 2270 (not (equal (car history) newelt)))) 2271 (if history-delete-duplicates 2272 (setq history (delete newelt history))) 2273 (setq history (cons newelt history)) 2274 (when (integerp maxelt) 2275 (if (>= 0 maxelt) 2276 (setq history nil) 2277 (setq tail (nthcdr (1- maxelt) history)) 2278 (when (consp tail) 2279 (setcdr tail nil)))) 2280 (set history-var history)))) 2281 2282 2283;;;; Mode hooks. 2284 2285(defvar delay-mode-hooks nil 2286 "If non-nil, `run-mode-hooks' should delay running the hooks.") 2287(defvar-local delayed-mode-hooks nil 2288 "List of delayed mode hooks waiting to be run.") 2289(put 'delay-mode-hooks 'permanent-local t) 2290 2291(defvar-local delayed-after-hook-functions nil 2292 "List of delayed :after-hook forms waiting to be run. 2293These forms come from `define-derived-mode'.") 2294 2295(defvar change-major-mode-after-body-hook nil 2296 "Normal hook run in major mode functions, before the mode hooks.") 2297 2298(defvar after-change-major-mode-hook nil 2299 "Normal hook run at the very end of major mode functions.") 2300 2301(defun run-mode-hooks (&rest hooks) 2302 "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS. 2303Call `hack-local-variables' to set up file local and directory local 2304variables. 2305 2306If the variable `delay-mode-hooks' is non-nil, does not do anything, 2307just adds the HOOKS to the list `delayed-mode-hooks'. 2308Otherwise, runs hooks in the sequence: `change-major-mode-after-body-hook', 2309`delayed-mode-hooks' (in reverse order), HOOKS, then runs 2310`hack-local-variables', runs the hook `after-change-major-mode-hook', and 2311finally evaluates the functions in `delayed-after-hook-functions' (see 2312`define-derived-mode'). 2313 2314Major mode functions should use this instead of `run-hooks' when 2315running their FOO-mode-hook." 2316 (if delay-mode-hooks 2317 ;; Delaying case. 2318 (dolist (hook hooks) 2319 (push hook delayed-mode-hooks)) 2320 ;; Normal case, just run the hook as before plus any delayed hooks. 2321 (setq hooks (nconc (nreverse delayed-mode-hooks) hooks)) 2322 (and (bound-and-true-p syntax-propertize-function) 2323 (not (local-variable-p 'parse-sexp-lookup-properties)) 2324 ;; `syntax-propertize' sets `parse-sexp-lookup-properties' for us, but 2325 ;; in order for the sexp primitives to automatically call 2326 ;; `syntax-propertize' we need `parse-sexp-lookup-properties' to be 2327 ;; set first. 2328 (setq-local parse-sexp-lookup-properties t)) 2329 (setq delayed-mode-hooks nil) 2330 (apply #'run-hooks (cons 'change-major-mode-after-body-hook hooks)) 2331 (if (buffer-file-name) 2332 (with-demoted-errors "File local-variables error: %s" 2333 (hack-local-variables 'no-mode))) 2334 (run-hooks 'after-change-major-mode-hook) 2335 (dolist (fun (prog1 (nreverse delayed-after-hook-functions) 2336 (setq delayed-after-hook-functions nil))) 2337 (funcall fun)))) 2338 2339(defmacro delay-mode-hooks (&rest body) 2340 "Execute BODY, but delay any `run-mode-hooks'. 2341These hooks will be executed by the first following call to 2342`run-mode-hooks' that occurs outside any `delay-mode-hooks' form. 2343Affects only hooks run in the current buffer." 2344 (declare (debug t) (indent 0)) 2345 `(progn 2346 (make-local-variable 'delay-mode-hooks) 2347 (let ((delay-mode-hooks t)) 2348 ,@body))) 2349 2350;; PUBLIC: find if the current mode derives from another. 2351 2352(defun provided-mode-derived-p (mode &rest modes) 2353 "Non-nil if MODE is derived from one of MODES. 2354Uses the `derived-mode-parent' property of the symbol to trace backwards. 2355If you just want to check `major-mode', use `derived-mode-p'." 2356 ;; If MODE is an alias, then look up the real mode function first. 2357 (when-let ((alias (symbol-function mode))) 2358 (when (symbolp alias) 2359 (setq mode alias))) 2360 (while 2361 (and 2362 (not (memq mode modes)) 2363 (let* ((parent (get mode 'derived-mode-parent)) 2364 (parentfn (symbol-function parent))) 2365 (setq mode (if (and parentfn (symbolp parentfn)) parentfn parent))))) 2366 mode) 2367 2368(defun derived-mode-p (&rest modes) 2369 "Non-nil if the current major mode is derived from one of MODES. 2370Uses the `derived-mode-parent' property of the symbol to trace backwards." 2371 (apply #'provided-mode-derived-p major-mode modes)) 2372 2373(defvar-local major-mode--suspended nil) 2374(put 'major-mode--suspended 'permanent-local t) 2375 2376(defun major-mode-suspend () 2377 "Exit current major mode, remembering it." 2378 (let* ((prev-major-mode (or major-mode--suspended 2379 (unless (eq major-mode 'fundamental-mode) 2380 major-mode)))) 2381 (kill-all-local-variables) 2382 (setq-local major-mode--suspended prev-major-mode))) 2383 2384(defun major-mode-restore (&optional avoided-modes) 2385 "Restore major mode earlier suspended with `major-mode-suspend'. 2386If there was no earlier suspended major mode, then fallback to `normal-mode', 2387tho trying to avoid AVOIDED-MODES." 2388 (if major-mode--suspended 2389 (funcall (prog1 major-mode--suspended 2390 (kill-local-variable 'major-mode--suspended))) 2391 (let ((auto-mode-alist 2392 (let ((alist (copy-sequence auto-mode-alist))) 2393 (dolist (mode avoided-modes) 2394 (setq alist (rassq-delete-all mode alist))) 2395 alist)) 2396 (magic-fallback-mode-alist 2397 (let ((alist (copy-sequence magic-fallback-mode-alist))) 2398 (dolist (mode avoided-modes) 2399 (setq alist (rassq-delete-all mode alist))) 2400 alist))) 2401 (normal-mode)))) 2402 2403;;;; Minor modes. 2404 2405;; If a minor mode is not defined with define-minor-mode, 2406;; add it here explicitly. 2407;; isearch-mode is deliberately excluded, since you should 2408;; not call it yourself. 2409(defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode 2410 overwrite-mode view-mode 2411 hs-minor-mode) 2412 "List of all minor mode functions.") 2413 2414(defun add-minor-mode (toggle name &optional keymap after toggle-fun) 2415 "Register a new minor mode. 2416 2417This function shouldn't be used directly -- use `define-minor-mode' 2418instead (which will then call this function). 2419 2420TOGGLE is a symbol that is the name of a buffer-local variable that 2421is toggled on or off to say whether the minor mode is active or not. 2422 2423NAME specifies what will appear in the mode line when the minor mode 2424is active. NAME should be either a string starting with a space, or a 2425symbol whose value is such a string. 2426 2427Optional KEYMAP is the keymap for the minor mode that will be added 2428to `minor-mode-map-alist'. 2429 2430Optional AFTER specifies that TOGGLE should be added after AFTER 2431in `minor-mode-alist'. 2432 2433Optional TOGGLE-FUN is an interactive function to toggle the mode. 2434It defaults to (and should by convention be) TOGGLE. 2435 2436If TOGGLE has a non-nil `:included' property, an entry for the mode is 2437included in the mode-line minor mode menu. 2438If TOGGLE has a `:menu-tag', that is used for the menu item's label." 2439 (unless (memq toggle minor-mode-list) 2440 (push toggle minor-mode-list)) 2441 2442 (unless toggle-fun (setq toggle-fun toggle)) 2443 (unless (eq toggle-fun toggle) 2444 (put toggle :minor-mode-function toggle-fun)) 2445 ;; Add the name to the minor-mode-alist. 2446 (when name 2447 (let ((existing (assq toggle minor-mode-alist))) 2448 (if existing 2449 (setcdr existing (list name)) 2450 (let ((tail minor-mode-alist) found) 2451 (while (and tail (not found)) 2452 (if (eq after (caar tail)) 2453 (setq found tail) 2454 (setq tail (cdr tail)))) 2455 (if found 2456 (let ((rest (cdr found))) 2457 (setcdr found nil) 2458 (nconc found (list (list toggle name)) rest)) 2459 (push (list toggle name) minor-mode-alist)))))) 2460 ;; Add the toggle to the minor-modes menu if requested. 2461 (when (get toggle :included) 2462 (define-key mode-line-mode-menu 2463 (vector toggle) 2464 (list 'menu-item 2465 (concat 2466 (or (get toggle :menu-tag) 2467 (if (stringp name) name (symbol-name toggle))) 2468 (let ((mode-name (if (symbolp name) (symbol-value name)))) 2469 (if (and (stringp mode-name) (string-match "[^ ]+" mode-name)) 2470 (concat " (" (match-string 0 mode-name) ")")))) 2471 toggle-fun 2472 :button (cons :toggle toggle)))) 2473 2474 ;; Add the map to the minor-mode-map-alist. 2475 (when keymap 2476 (let ((existing (assq toggle minor-mode-map-alist))) 2477 (if existing 2478 (setcdr existing keymap) 2479 (let ((tail minor-mode-map-alist) found) 2480 (while (and tail (not found)) 2481 (if (eq after (caar tail)) 2482 (setq found tail) 2483 (setq tail (cdr tail)))) 2484 (if found 2485 (let ((rest (cdr found))) 2486 (setcdr found nil) 2487 (nconc found (list (cons toggle keymap)) rest)) 2488 (push (cons toggle keymap) minor-mode-map-alist))))))) 2489 2490;;;; Load history 2491 2492(defsubst autoloadp (object) 2493 "Non-nil if OBJECT is an autoload." 2494 (eq 'autoload (car-safe object))) 2495 2496;; (defun autoload-type (object) 2497;; "Returns the type of OBJECT or `function' or `command' if the type is nil. 2498;; OBJECT should be an autoload object." 2499;; (when (autoloadp object) 2500;; (let ((type (nth 3 object))) 2501;; (cond ((null type) (if (nth 2 object) 'command 'function)) 2502;; ((eq 'keymap t) 'macro) 2503;; (type))))) 2504 2505;; (defalias 'autoload-file #'cadr 2506;; "Return the name of the file from which AUTOLOAD will be loaded. 2507;; \n\(fn AUTOLOAD)") 2508 2509(defun define-symbol-prop (symbol prop val) 2510 "Define the property PROP of SYMBOL to be VAL. 2511This is to `put' what `defalias' is to `fset'." 2512 ;; Can't use `cl-pushnew' here (nor `push' on (cdr foo)). 2513 ;; (cl-pushnew symbol (alist-get prop 2514 ;; (alist-get 'define-symbol-props 2515 ;; current-load-list))) 2516 (let ((sps (assq 'define-symbol-props current-load-list))) 2517 (unless sps 2518 (setq sps (list 'define-symbol-props)) 2519 (push sps current-load-list)) 2520 (let ((ps (assq prop sps))) 2521 (unless ps 2522 (setq ps (list prop)) 2523 (setcdr sps (cons ps (cdr sps)))) 2524 (unless (member symbol (cdr ps)) 2525 (setcdr ps (cons symbol (cdr ps)))))) 2526 (put symbol prop val)) 2527 2528(defun symbol-file (symbol &optional type) 2529 "Return the name of the file that defined SYMBOL. 2530The value is normally an absolute file name. It can also be nil, 2531if the definition is not associated with any file. If SYMBOL 2532specifies an autoloaded function, the value can be a relative 2533file name without extension. 2534 2535If TYPE is nil, then any kind of definition is acceptable. If 2536TYPE is `defun', `defvar', or `defface', that specifies function 2537definition, variable definition, or face definition only. 2538Otherwise TYPE is assumed to be a symbol property. 2539 2540This function only works for symbols defined in Lisp files. For 2541symbols that are defined in C files, use `help-C-file-name' 2542instead." 2543 (if (and (or (null type) (eq type 'defun)) 2544 (symbolp symbol) 2545 (autoloadp (symbol-function symbol))) 2546 (nth 1 (symbol-function symbol)) 2547 (catch 'found 2548 (pcase-dolist (`(,file . ,elems) load-history) 2549 (when (if type 2550 (if (eq type 'defvar) 2551 ;; Variables are present just as their names. 2552 (member symbol elems) 2553 ;; Many other types are represented as (TYPE . NAME). 2554 (or (member (cons type symbol) elems) 2555 (memq symbol (alist-get type 2556 (alist-get 'define-symbol-props 2557 elems))))) 2558 ;; We accept all types, so look for variable def 2559 ;; and then for any other kind. 2560 (or (member symbol elems) 2561 (let ((match (rassq symbol elems))) 2562 (and match 2563 (not (eq 'require (car match))))))) 2564 (throw 'found file)))))) 2565 2566(declare-function read-library-name "find-func" nil) 2567 2568(defun locate-library (library &optional nosuffix path interactive-call) 2569 "Show the precise file name of Emacs library LIBRARY. 2570LIBRARY should be a relative file name of the library, a string. 2571It can omit the suffix (a.k.a. file-name extension) if NOSUFFIX is 2572nil (which is the default, see below). 2573This command searches the directories in `load-path' like `\\[load-library]' 2574to find the file that `\\[load-library] RET LIBRARY RET' would load. 2575Optional second arg NOSUFFIX non-nil means don't add suffixes `load-suffixes' 2576to the specified name LIBRARY. 2577 2578If the optional third arg PATH is specified, that list of directories 2579is used instead of `load-path'. 2580 2581When called from a program, the file name is normally returned as a 2582string. When run interactively, the argument INTERACTIVE-CALL is t, 2583and the file name is displayed in the echo area." 2584 (interactive (list (read-library-name) nil nil t)) 2585 (let ((file (locate-file library 2586 (or path load-path) 2587 (append (unless nosuffix (get-load-suffixes)) 2588 load-file-rep-suffixes)))) 2589 (if interactive-call 2590 (if file 2591 (message "Library is file %s" (abbreviate-file-name file)) 2592 (message "No library %s in search path" library))) 2593 file)) 2594 2595 2596;;;; Process stuff. 2597 2598(defun start-process (name buffer program &rest program-args) 2599 "Start a program in a subprocess. Return the process object for it. 2600NAME is name for process. It is modified if necessary to make it unique. 2601BUFFER is the buffer (or buffer name) to associate with the process. 2602 2603Process output (both standard output and standard error streams) 2604goes at end of BUFFER, unless you specify a filter function to 2605handle the output. BUFFER may also be nil, meaning that this 2606process is not associated with any buffer. 2607 2608PROGRAM is the program file name. It is searched for in `exec-path' 2609\(which see). If nil, just associate a pty with the buffer. Remaining 2610arguments PROGRAM-ARGS are strings to give program as arguments. 2611 2612If you want to separate standard output from standard error, use 2613`make-process' or invoke the command through a shell and redirect 2614one of them using the shell syntax. 2615 2616The process runs in `default-directory' if that is local (as 2617determined by `unhandled-file-name-directory'), or \"~\" 2618otherwise. If you want to run a process in a remote directory 2619use `start-file-process'." 2620 (unless (fboundp 'make-process) 2621 (error "Emacs was compiled without subprocess support")) 2622 (apply #'make-process 2623 (append (list :name name :buffer buffer) 2624 (if program 2625 (list :command (cons program program-args)))))) 2626 2627(defun process-lines-handling-status (program status-handler &rest args) 2628 "Execute PROGRAM with ARGS, returning its output as a list of lines. 2629If STATUS-HANDLER is non-nil, it must be a function with one 2630argument, which will be called with the exit status of the 2631program before the output is collected. If STATUS-HANDLER is 2632nil, an error is signaled if the program returns with a non-zero 2633exit status." 2634 (with-temp-buffer 2635 (let ((status (apply #'call-process program nil (current-buffer) nil args))) 2636 (if status-handler 2637 (funcall status-handler status) 2638 (unless (eq status 0) 2639 (error "%s exited with status %s" program status))) 2640 (goto-char (point-min)) 2641 (let (lines) 2642 (while (not (eobp)) 2643 (setq lines (cons (buffer-substring-no-properties 2644 (line-beginning-position) 2645 (line-end-position)) 2646 lines)) 2647 (forward-line 1)) 2648 (nreverse lines))))) 2649 2650(defun process-lines (program &rest args) 2651 "Execute PROGRAM with ARGS, returning its output as a list of lines. 2652Signal an error if the program returns with a non-zero exit status. 2653Also see `process-lines-ignore-status'." 2654 (apply #'process-lines-handling-status program nil args)) 2655 2656(defun process-lines-ignore-status (program &rest args) 2657 "Execute PROGRAM with ARGS, returning its output as a list of lines. 2658The exit status of the program is ignored. 2659Also see `process-lines'." 2660 (apply #'process-lines-handling-status program #'ignore args)) 2661 2662(defun process-live-p (process) 2663 "Return non-nil if PROCESS is alive. 2664A process is considered alive if its status is `run', `open', 2665`listen', `connect' or `stop'. Value is nil if PROCESS is not a 2666process." 2667 (and (processp process) 2668 (memq (process-status process) 2669 '(run open listen connect stop)))) 2670 2671(defun process-kill-buffer-query-function () 2672 "Ask before killing a buffer that has a running process." 2673 (let ((process (get-buffer-process (current-buffer)))) 2674 (or (not process) 2675 (not (memq (process-status process) '(run stop open listen))) 2676 (not (process-query-on-exit-flag process)) 2677 (yes-or-no-p 2678 (format "Buffer %S has a running process; kill it? " 2679 (buffer-name (current-buffer))))))) 2680 2681(add-hook 'kill-buffer-query-functions #'process-kill-buffer-query-function) 2682 2683;; process plist management 2684 2685(defun process-get (process propname) 2686 "Return the value of PROCESS' PROPNAME property. 2687This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'." 2688 (plist-get (process-plist process) propname)) 2689 2690(defun process-put (process propname value) 2691 "Change PROCESS' PROPNAME property to VALUE. 2692It can be retrieved with `(process-get PROCESS PROPNAME)'." 2693 (set-process-plist process 2694 (plist-put (process-plist process) propname value))) 2695 2696(defun memory-limit () 2697 "Return an estimate of Emacs virtual memory usage, divided by 1024." 2698 (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0)) 2699 2700 2701;;;; Input and display facilities. 2702 2703;; The following maps are used by `read-key' to remove all key 2704;; bindings while calling `read-key-sequence'. This way the keys 2705;; returned are independent of the key binding state. 2706 2707(defconst read-key-empty-map (make-sparse-keymap) 2708 "Used internally by `read-key'.") 2709 2710(defconst read-key-full-map 2711 (let ((map (make-sparse-keymap))) 2712 (define-key map [t] 'dummy) 2713 2714 ;; ESC needs to be unbound so that escape sequences in 2715 ;; `input-decode-map' are still processed by `read-key-sequence'. 2716 (define-key map [?\e] nil) 2717 map) 2718 "Used internally by `read-key'.") 2719 2720(defvar read-key-delay 0.01) ;Fast enough for 100Hz repeat rate, hopefully. 2721 2722(defun read-key (&optional prompt disable-fallbacks) 2723 "Read a key from the keyboard. 2724Contrary to `read-event' this will not return a raw event but instead will 2725obey the input decoding and translations usually done by `read-key-sequence'. 2726So escape sequences and keyboard encoding are taken into account. 2727When there's an ambiguity because the key looks like the prefix of 2728some sort of escape sequence, the ambiguity is resolved via `read-key-delay'. 2729 2730If the optional argument PROMPT is non-nil, display that as a 2731prompt. 2732 2733If the optional argument DISABLE-FALLBACKS is non-nil, all 2734unbound fallbacks usually done by `read-key-sequence' are 2735disabled such as discarding mouse down events. This is generally 2736what you want as `read-key' temporarily removes all bindings 2737while calling `read-key-sequence'. If nil or unspecified, the 2738only unbound fallback disabled is downcasing of the last event." 2739 ;; This overriding-terminal-local-map binding also happens to 2740 ;; disable quail's input methods, so although read-key-sequence 2741 ;; always inherits the input method, in practice read-key does not 2742 ;; inherit the input method (at least not if it's based on quail). 2743 (let ((overriding-terminal-local-map nil) 2744 (overriding-local-map 2745 ;; FIXME: Audit existing uses of `read-key' to see if they 2746 ;; should always specify disable-fallbacks to be more in line 2747 ;; with `read-event'. 2748 (if disable-fallbacks read-key-full-map read-key-empty-map)) 2749 (echo-keystrokes 0) 2750 (old-global-map (current-global-map)) 2751 (timer (run-with-idle-timer 2752 ;; Wait long enough that Emacs has the time to receive and 2753 ;; process all the raw events associated with the single-key. 2754 ;; But don't wait too long, or the user may find the delay 2755 ;; annoying (or keep hitting more keys, which may then get 2756 ;; lost or misinterpreted). 2757 ;; This is relevant only for keys that Emacs perceives as 2758 ;; "prefixes", such as C-x (because of the C-x 8 map in 2759 ;; key-translate-table and the C-x @ map in function-key-map) 2760 ;; or ESC (because of terminal escape sequences in 2761 ;; input-decode-map). 2762 read-key-delay t 2763 (lambda () 2764 (let ((keys (this-command-keys-vector))) 2765 (unless (zerop (length keys)) 2766 ;; `keys' is non-empty, so the user has hit at least 2767 ;; one key; there's no point waiting any longer, even 2768 ;; though read-key-sequence thinks we should wait 2769 ;; for more input to decide how to interpret the 2770 ;; current input. 2771 (throw 'read-key keys))))))) 2772 (unwind-protect 2773 (progn 2774 (use-global-map 2775 (let ((map (make-sparse-keymap))) 2776 ;; Don't hide the menu-bar, tab-bar and tool-bar entries. 2777 (define-key map [menu-bar] (lookup-key global-map [menu-bar])) 2778 (define-key map [tab-bar] 2779 ;; This hack avoids evaluating the :filter (Bug#9922). 2780 (or (cdr (assq 'tab-bar global-map)) 2781 (lookup-key global-map [tab-bar]))) 2782 (define-key map [tool-bar] 2783 ;; This hack avoids evaluating the :filter (Bug#9922). 2784 (or (cdr (assq 'tool-bar global-map)) 2785 (lookup-key global-map [tool-bar]))) 2786 map)) 2787 (let* ((keys 2788 (catch 'read-key (read-key-sequence-vector prompt nil t))) 2789 (key (aref keys 0))) 2790 (if (and (> (length keys) 1) 2791 (memq key '(mode-line header-line 2792 left-fringe right-fringe))) 2793 (aref keys 1) 2794 key))) 2795 (cancel-timer timer) 2796 ;; For some reason, `read-key(-sequence)' leaves the prompt in the echo 2797 ;; area, whereas `read-event' seems to empty it just before returning 2798 ;; (bug#22714). So, let's mimic the behavior of `read-event'. 2799 (message nil) 2800 (use-global-map old-global-map)))) 2801 2802;; FIXME: Once there's a safe way to transition away from read-event, 2803;; callers to this function should be updated to that way and this 2804;; function should be deleted. 2805(defun read--potential-mouse-event () 2806 "Read an event that might be a mouse event. 2807 2808This function exists for backward compatibility in code packaged 2809with Emacs. Do not call it directly in your own packages." 2810 ;; `xterm-mouse-mode' events must go through `read-key' as they 2811 ;; are decoded via `input-decode-map'. 2812 (if xterm-mouse-mode 2813 (read-key nil 2814 ;; Normally `read-key' discards all mouse button 2815 ;; down events. However, we want them here. 2816 t) 2817 (read-event))) 2818 2819(defvar read-passwd-map 2820 ;; BEWARE: `defconst' would purecopy it, breaking the sharing with 2821 ;; minibuffer-local-map along the way! 2822 (let ((map (make-sparse-keymap))) 2823 (set-keymap-parent map minibuffer-local-map) 2824 (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570 2825 map) 2826 "Keymap used while reading passwords.") 2827 2828(defun read-password--hide-password () 2829 (let ((beg (minibuffer-prompt-end))) 2830 (dotimes (i (1+ (- (buffer-size) beg))) 2831 (put-text-property (+ i beg) (+ 1 i beg) 2832 'display (string (or read-hide-char ?*)))))) 2833 2834(defun read-passwd (prompt &optional confirm default) 2835 "Read a password, prompting with PROMPT, and return it. 2836If optional CONFIRM is non-nil, read the password twice to make sure. 2837Optional DEFAULT is a default password to use instead of empty input. 2838 2839This function echoes `*' for each character that the user types. 2840You could let-bind `read-hide-char' to another hiding character, though. 2841 2842Once the caller uses the password, it can erase the password 2843by doing (clear-string STRING)." 2844 (if confirm 2845 (let (success) 2846 (while (not success) 2847 (let ((first (read-passwd prompt nil default)) 2848 (second (read-passwd "Confirm password: " nil default))) 2849 (if (equal first second) 2850 (progn 2851 (and (arrayp second) (not (eq first second)) (clear-string second)) 2852 (setq success first)) 2853 (and (arrayp first) (clear-string first)) 2854 (and (arrayp second) (clear-string second)) 2855 (message "Password not repeated accurately; please start over") 2856 (sit-for 1)))) 2857 success) 2858 (let (minibuf) 2859 (minibuffer-with-setup-hook 2860 (lambda () 2861 (setq minibuf (current-buffer)) 2862 ;; Turn off electricity. 2863 (setq-local post-self-insert-hook nil) 2864 (setq-local buffer-undo-list t) 2865 (setq-local select-active-regions nil) 2866 (use-local-map read-passwd-map) 2867 (setq-local inhibit-modification-hooks nil) ;bug#15501. 2868 (setq-local show-paren-mode nil) ;bug#16091. 2869 (add-hook 'post-command-hook #'read-password--hide-password nil t)) 2870 (unwind-protect 2871 (let ((enable-recursive-minibuffers t) 2872 (read-hide-char (or read-hide-char ?*))) 2873 (read-string prompt nil t default)) ; t = "no history" 2874 (when (buffer-live-p minibuf) 2875 (with-current-buffer minibuf 2876 ;; Not sure why but it seems that there might be cases where the 2877 ;; minibuffer is not always properly reset later on, so undo 2878 ;; whatever we've done here (bug#11392). 2879 (remove-hook 'after-change-functions 2880 #'read-password--hide-password 'local) 2881 (kill-local-variable 'post-self-insert-hook) 2882 ;; And of course, don't keep the sensitive data around. 2883 (erase-buffer)))))))) 2884 2885(defvar read-number-history nil 2886 "The default history for the `read-number' function.") 2887 2888(defun read-number (prompt &optional default hist) 2889 "Read a numeric value in the minibuffer, prompting with PROMPT. 2890DEFAULT specifies a default value to return if the user just types RET. 2891The value of DEFAULT is inserted into PROMPT. 2892HIST specifies a history list variable. See `read-from-minibuffer' 2893for details of the HIST argument. 2894This function is used by the `interactive' code letter `n'." 2895 (let ((n nil) 2896 (default1 (if (consp default) (car default) default))) 2897 (when default1 2898 (setq prompt 2899 (if (string-match "\\(\\):[ \t]*\\'" prompt) 2900 (replace-match (format minibuffer-default-prompt-format default1) t t prompt 1) 2901 (replace-regexp-in-string "[ \t]*\\'" 2902 (format minibuffer-default-prompt-format default1) 2903 prompt t t)))) 2904 (while 2905 (progn 2906 (let ((str (read-from-minibuffer 2907 prompt nil nil nil (or hist 'read-number-history) 2908 (when default 2909 (if (consp default) 2910 (mapcar #'number-to-string (delq nil default)) 2911 (number-to-string default)))))) 2912 (condition-case nil 2913 (setq n (cond 2914 ((zerop (length str)) default1) 2915 ((stringp str) (read str)))) 2916 (error nil))) 2917 (unless (numberp n) 2918 (message "Please enter a number.") 2919 (sit-for 1) 2920 t))) 2921 n)) 2922 2923(defvar read-char-choice-use-read-key nil 2924 "Prefer `read-key' when reading a character by `read-char-choice'. 2925Otherwise, use the minibuffer. 2926 2927When using the minibuffer, the user is less constrained, and can 2928use the normal commands available in the minibuffer, and can, for 2929instance, switch to another buffer, do things there, and then 2930switch back again to the minibuffer before entering the 2931character. This is not possible when using `read-key', but using 2932`read-key' may be less confusing to some users.") 2933 2934(defun read-char-choice (prompt chars &optional inhibit-keyboard-quit) 2935 "Read and return one of CHARS, prompting for PROMPT. 2936Any input that is not one of CHARS is ignored. 2937 2938By default, the minibuffer is used to read the key 2939non-modally (see `read-char-from-minibuffer'). If 2940`read-char-choice-use-read-key' is non-nil, the modal `read-key' 2941function is used instead (see `read-char-choice-with-read-key')." 2942 (if (not read-char-choice-use-read-key) 2943 (read-char-from-minibuffer prompt chars) 2944 (read-char-choice-with-read-key prompt chars inhibit-keyboard-quit))) 2945 2946(defun read-char-choice-with-read-key (prompt chars &optional inhibit-keyboard-quit) 2947 "Read and return one of CHARS, prompting for PROMPT. 2948Any input that is not one of CHARS is ignored. 2949 2950If optional argument INHIBIT-KEYBOARD-QUIT is non-nil, ignore 2951`keyboard-quit' events while waiting for a valid input. 2952 2953If you bind the variable `help-form' to a non-nil value 2954while calling this function, then pressing `help-char' 2955causes it to evaluate `help-form' and display the result." 2956 (unless (consp chars) 2957 (error "Called `read-char-choice' without valid char choices")) 2958 (let (char done show-help (helpbuf " *Char Help*")) 2959 (let ((cursor-in-echo-area t) 2960 (executing-kbd-macro executing-kbd-macro) 2961 (esc-flag nil)) 2962 (save-window-excursion ; in case we call help-form-show 2963 (while (not done) 2964 (unless (get-text-property 0 'face prompt) 2965 (setq prompt (propertize prompt 'face 'minibuffer-prompt))) 2966 (setq char (let ((inhibit-quit inhibit-keyboard-quit)) 2967 (read-key prompt))) 2968 (and show-help (buffer-live-p (get-buffer helpbuf)) 2969 (kill-buffer helpbuf)) 2970 (cond 2971 ((not (numberp char))) 2972 ;; If caller has set help-form, that's enough. 2973 ;; They don't explicitly have to add help-char to chars. 2974 ((and help-form 2975 (eq char help-char) 2976 (setq show-help t) 2977 (help-form-show))) 2978 ((memq char chars) 2979 (setq done t)) 2980 ((and executing-kbd-macro (= char -1)) 2981 ;; read-event returns -1 if we are in a kbd macro and 2982 ;; there are no more events in the macro. Attempt to 2983 ;; get an event interactively. 2984 (setq executing-kbd-macro nil)) 2985 ((not inhibit-keyboard-quit) 2986 (cond 2987 ((and (null esc-flag) (eq char ?\e)) 2988 (setq esc-flag t)) 2989 ((memq char '(?\C-g ?\e)) 2990 (keyboard-quit)))))))) 2991 ;; Display the question with the answer. But without cursor-in-echo-area. 2992 (message "%s%s" prompt (char-to-string char)) 2993 char)) 2994 2995(defun sit-for (seconds &optional nodisp obsolete) 2996 "Redisplay, then wait for SECONDS seconds. Stop when input is available. 2997SECONDS may be a floating-point value. 2998\(On operating systems that do not support waiting for fractions of a 2999second, floating-point values are rounded down to the nearest integer.) 3000 3001If optional arg NODISP is t, don't redisplay, just wait for input. 3002Redisplay does not happen if input is available before it starts. 3003 3004Value is t if waited the full time with no input arriving, and nil otherwise. 3005 3006An obsolete, but still supported form is 3007\(sit-for SECONDS &optional MILLISECONDS NODISP) 3008where the optional arg MILLISECONDS specifies an additional wait period, 3009in milliseconds; this was useful when Emacs was built without 3010floating point support." 3011 (declare (advertised-calling-convention (seconds &optional nodisp) "22.1")) 3012 ;; This used to be implemented in C until the following discussion: 3013 ;; https://lists.gnu.org/r/emacs-devel/2006-07/msg00401.html 3014 ;; Then it was moved here using an implementation based on an idle timer, 3015 ;; which was then replaced by the use of read-event. 3016 (if (numberp nodisp) 3017 (setq seconds (+ seconds (* 1e-3 nodisp)) 3018 nodisp obsolete) 3019 (if obsolete (setq nodisp obsolete))) 3020 (cond 3021 (noninteractive 3022 (sleep-for seconds) 3023 t) 3024 ((input-pending-p t) 3025 nil) 3026 ((or (<= seconds 0) 3027 ;; We are going to call read-event below, which will record 3028 ;; the next key as part of the macro, even if that key 3029 ;; invokes kmacro-end-macro, so if we are recording a macro, 3030 ;; the macro will recursively call itself. In addition, when 3031 ;; that key is removed from unread-command-events, it will be 3032 ;; recorded the second time, so the macro will have each key 3033 ;; doubled. This used to happen if a macro was defined with 3034 ;; Flyspell mode active (because Flyspell calls sit-for in its 3035 ;; post-command-hook, see bug #21329.) To avoid all that, we 3036 ;; simply disable the wait when we are recording a macro. 3037 defining-kbd-macro) 3038 (or nodisp (redisplay))) 3039 (t 3040 (or nodisp (redisplay)) 3041 ;; FIXME: we should not read-event here at all, because it's much too 3042 ;; difficult to reliably "undo" a read-event by pushing it onto 3043 ;; unread-command-events. 3044 ;; For bug#14782, we need read-event to do the keyboard-coding-system 3045 ;; decoding (hence non-nil as second arg under POSIX ttys). 3046 ;; For bug#15614, we need read-event not to inherit-input-method. 3047 ;; So we temporarily suspend input-method-function. 3048 (let ((read (let ((input-method-function nil)) 3049 (read-event nil t seconds)))) 3050 (or (null read) 3051 (progn 3052 ;; https://lists.gnu.org/r/emacs-devel/2006-10/msg00394.html 3053 ;; We want `read' appear in the next command's this-command-event 3054 ;; but not in the current one. 3055 ;; By pushing (cons t read), we indicate that `read' has not 3056 ;; yet been recorded in this-command-keys, so it will be recorded 3057 ;; next time it's read. 3058 ;; And indeed the `seconds' argument to read-event correctly 3059 ;; prevented recording this event in the current command's 3060 ;; this-command-keys. 3061 (push (cons t read) unread-command-events) 3062 nil)))))) 3063 3064(defun goto-char--read-natnum-interactive (prompt) 3065 "Get a natural number argument, optionally prompting with PROMPT. 3066If there is a natural number at point, use it as default." 3067 (if (and current-prefix-arg (not (consp current-prefix-arg))) 3068 (list (prefix-numeric-value current-prefix-arg)) 3069 (let* ((number (number-at-point)) 3070 (default (and (natnump number) number))) 3071 (list (read-number prompt (list default (point))))))) 3072 3073 3074(defvar read-char-history nil 3075 "The default history for the `read-char-from-minibuffer' function.") 3076 3077(defvar read-char-from-minibuffer-map 3078 (let ((map (make-sparse-keymap))) 3079 (set-keymap-parent map minibuffer-local-map) 3080 3081 (define-key map [remap self-insert-command] #'read-char-from-minibuffer-insert-char) 3082 (define-key map [remap exit-minibuffer] #'read-char-from-minibuffer-insert-other) 3083 3084 (define-key map [remap recenter-top-bottom] #'minibuffer-recenter-top-bottom) 3085 (define-key map [remap scroll-up-command] #'minibuffer-scroll-up-command) 3086 (define-key map [remap scroll-down-command] #'minibuffer-scroll-down-command) 3087 (define-key map [remap scroll-other-window] #'minibuffer-scroll-other-window) 3088 (define-key map [remap scroll-other-window-down] #'minibuffer-scroll-other-window-down) 3089 3090 map) 3091 "Keymap for the `read-char-from-minibuffer' function.") 3092 3093(defconst read-char-from-minibuffer-map-hash 3094 (make-hash-table :test 'equal)) 3095 3096(defun read-char-from-minibuffer-insert-char () 3097 "Insert the character you type in the minibuffer and exit. 3098Discard all previous input before inserting and exiting the minibuffer." 3099 (interactive) 3100 (when (minibufferp) 3101 (delete-minibuffer-contents) 3102 (insert last-command-event) 3103 (exit-minibuffer))) 3104 3105(defun read-char-from-minibuffer-insert-other () 3106 "Handle inserting of a character other than allowed. 3107Display an error on trying to insert a disallowed character. 3108Also discard all previous input in the minibuffer." 3109 (interactive) 3110 (when (minibufferp) 3111 (delete-minibuffer-contents) 3112 (ding) 3113 (discard-input) 3114 (minibuffer-message "Wrong answer") 3115 (sit-for 2))) 3116 3117(defun read-char-from-minibuffer (prompt &optional chars history) 3118 "Read a character from the minibuffer, prompting for it with PROMPT. 3119Like `read-char', but uses the minibuffer to read and return a character. 3120Optional argument CHARS, if non-nil, should be a list of characters; 3121the function will ignore any input that is not one of CHARS. 3122Optional argument HISTORY, if non-nil, should be a symbol that 3123specifies the history list variable to use for navigating in input 3124history using \\`M-p' and \\`M-n', with \\`RET' to select a character from 3125history. 3126If you bind the variable `help-form' to a non-nil value 3127while calling this function, then pressing `help-char' 3128causes it to evaluate `help-form' and display the result. 3129There is no need to explicitly add `help-char' to CHARS; 3130`help-char' is bound automatically to `help-form-show'." 3131 (defvar empty-history) 3132 (let* ((empty-history '()) 3133 (map (if (consp chars) 3134 (or (gethash (list help-form (cons help-char chars)) 3135 read-char-from-minibuffer-map-hash) 3136 (let ((map (make-sparse-keymap)) 3137 (msg help-form)) 3138 (set-keymap-parent map read-char-from-minibuffer-map) 3139 ;; If we have a dynamically bound `help-form' 3140 ;; here, then the `C-h' (i.e., `help-char') 3141 ;; character should output that instead of 3142 ;; being a command char. 3143 (when help-form 3144 (define-key map (vector help-char) 3145 (lambda () 3146 (interactive) 3147 (let ((help-form msg)) ; lexically bound msg 3148 (help-form-show))))) 3149 (dolist (char chars) 3150 (define-key map (vector char) 3151 #'read-char-from-minibuffer-insert-char)) 3152 (define-key map [remap self-insert-command] 3153 #'read-char-from-minibuffer-insert-other) 3154 (puthash (list help-form (cons help-char chars)) 3155 map read-char-from-minibuffer-map-hash) 3156 map)) 3157 read-char-from-minibuffer-map)) 3158 ;; Protect this-command when called from pre-command-hook (bug#45029) 3159 (this-command this-command) 3160 (result 3161 (read-from-minibuffer prompt nil map nil 3162 (or history 'empty-history))) 3163 (char 3164 (if (> (length result) 0) 3165 ;; We have a string (with one character), so return the first one. 3166 (elt result 0) 3167 ;; The default value is RET. 3168 (when history (push "\r" (symbol-value history))) 3169 ?\r))) 3170 ;; Display the question with the answer. 3171 (message "%s%s" prompt (char-to-string char)) 3172 char)) 3173 3174 3175;; Behind display-popup-menus-p test. 3176(declare-function x-popup-dialog "menu.c" (position contents &optional header)) 3177 3178(defvar y-or-n-p-history-variable nil 3179 "History list symbol to add `y-or-n-p' answers to.") 3180 3181(defvar y-or-n-p-map 3182 (let ((map (make-sparse-keymap))) 3183 (set-keymap-parent map minibuffer-local-map) 3184 3185 (dolist (symbol '(act act-and-show act-and-exit automatic)) 3186 (define-key map (vector 'remap symbol) #'y-or-n-p-insert-y)) 3187 3188 (define-key map [remap skip] #'y-or-n-p-insert-n) 3189 3190 (dolist (symbol '(backup undo undo-all edit edit-replacement 3191 delete-and-edit ignore self-insert-command)) 3192 (define-key map (vector 'remap symbol) #'y-or-n-p-insert-other)) 3193 3194 (define-key map [remap recenter] #'minibuffer-recenter-top-bottom) 3195 (define-key map [remap scroll-up] #'minibuffer-scroll-up-command) 3196 (define-key map [remap scroll-down] #'minibuffer-scroll-down-command) 3197 (define-key map [remap scroll-other-window] #'minibuffer-scroll-other-window) 3198 (define-key map [remap scroll-other-window-down] #'minibuffer-scroll-other-window-down) 3199 3200 (define-key map [remap exit] #'y-or-n-p-insert-other) 3201 (dolist (symbol '(exit-prefix quit)) 3202 (define-key map (vector 'remap symbol) #'abort-recursive-edit)) 3203 (define-key map [escape] #'abort-recursive-edit) 3204 3205 ;; FIXME: try catch-all instead of explicit bindings: 3206 ;; (define-key map [remap t] #'y-or-n-p-insert-other) 3207 3208 map) 3209 "Keymap that defines additional bindings for `y-or-n-p' answers.") 3210 3211(defun y-or-n-p-insert-y () 3212 "Insert the answer \"y\" and exit the minibuffer of `y-or-n-p'. 3213Discard all previous input before inserting and exiting the minibuffer." 3214 (interactive) 3215 (when (minibufferp) 3216 (delete-minibuffer-contents) 3217 (insert "y") 3218 (exit-minibuffer))) 3219 3220(defun y-or-n-p-insert-n () 3221 "Insert the answer \"n\" and exit the minibuffer of `y-or-n-p'. 3222Discard all previous input before inserting and exiting the minibuffer." 3223 (interactive) 3224 (when (minibufferp) 3225 (delete-minibuffer-contents) 3226 (insert "n") 3227 (exit-minibuffer))) 3228 3229(defun y-or-n-p-insert-other () 3230 "Handle inserting of other answers in the minibuffer of `y-or-n-p'. 3231Display an error on trying to insert a disallowed character. 3232Also discard all previous input in the minibuffer." 3233 (interactive) 3234 (when (minibufferp) 3235 (delete-minibuffer-contents) 3236 (ding) 3237 (discard-input) 3238 (minibuffer-message "Please answer y or n") 3239 (sit-for 2))) 3240 3241(defvar y-or-n-p-use-read-key nil 3242 "Prefer `read-key' when answering a \"y or n\" question by `y-or-n-p'. 3243Otherwise, use the minibuffer. 3244 3245When using the minibuffer, the user is less constrained, and can 3246use the normal commands available in the minibuffer, and can, for 3247instance, switch to another buffer, do things there, and then 3248switch back again to the minibuffer before entering the 3249character. This is not possible when using `read-key', but using 3250`read-key' may be less confusing to some users.") 3251 3252(defun y-or-n-p (prompt) 3253 "Ask user a \"y or n\" question. 3254Return t if answer is \"y\" and nil if it is \"n\". 3255 3256PROMPT is the string to display to ask the question; `y-or-n-p' 3257adds \" (y or n) \" to it. It does not need to end in space, but 3258if it does up to one space will be removed. 3259 3260If you bind the variable `help-form' to a non-nil value 3261while calling this function, then pressing `help-char' 3262causes it to evaluate `help-form' and display the result. 3263PROMPT is also updated to show `help-char' like \"(y, n or C-h) \", 3264where `help-char' is automatically bound to `help-form-show'. 3265 3266No confirmation of the answer is requested; a single character is 3267enough. SPC also means yes, and DEL means no. 3268 3269To be precise, this function translates user input into responses 3270by consulting the bindings in `query-replace-map'; see the 3271documentation of that variable for more information. In this 3272case, the useful bindings are `act', `skip', `recenter', 3273`scroll-up', `scroll-down', and `quit'. 3274An `act' response means yes, and a `skip' response means no. 3275A `quit' response means to invoke `abort-recursive-edit'. 3276If the user enters `recenter', `scroll-up', or `scroll-down' 3277responses, perform the requested window recentering or scrolling 3278and ask again. 3279 3280Under a windowing system a dialog box will be used if `last-nonmenu-event' 3281is nil and `use-dialog-box' is non-nil. 3282 3283By default, this function uses the minibuffer to read the key. 3284If `y-or-n-p-use-read-key' is non-nil, `read-key' is used 3285instead (which means that the user can't change buffers (and the 3286like) while `y-or-n-p' is running)." 3287 (let ((answer 'recenter) 3288 (padded (lambda (prompt &optional dialog) 3289 (let ((l (length prompt))) 3290 (concat prompt 3291 (if (or (zerop l) (eq ?\s (aref prompt (1- l)))) 3292 "" " ") 3293 (if dialog "" 3294 (if help-form 3295 (format "(y, n or %s) " 3296 (key-description 3297 (vector help-char))) 3298 "(y or n) " 3299 ))))))) 3300 (cond 3301 (noninteractive 3302 (setq prompt (funcall padded prompt)) 3303 (let ((temp-prompt prompt)) 3304 (while (not (memq answer '(act skip))) 3305 (let ((str (read-string temp-prompt))) 3306 (cond ((member str '("y" "Y")) (setq answer 'act)) 3307 ((member str '("n" "N")) (setq answer 'skip)) 3308 ((and (member str '("h" "H")) help-form) (print help-form)) 3309 (t (setq temp-prompt (concat "Please answer y or n. " 3310 prompt)))))))) 3311 ((and (display-popup-menus-p) 3312 last-input-event ; not during startup 3313 (listp last-nonmenu-event) 3314 use-dialog-box) 3315 (setq prompt (funcall padded prompt t) 3316 answer (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip))))) 3317 (y-or-n-p-use-read-key 3318 ;; ¡Beware! when I tried to edebug this code, Emacs got into a weird state 3319 ;; where all the keys were unbound (i.e. it somehow got triggered 3320 ;; within read-key, apparently). I had to kill it. 3321 (setq prompt (funcall padded prompt)) 3322 (while 3323 (let* ((scroll-actions '(recenter scroll-up scroll-down 3324 scroll-other-window scroll-other-window-down)) 3325 (key 3326 (let ((cursor-in-echo-area t)) 3327 (when minibuffer-auto-raise 3328 (raise-frame (window-frame (minibuffer-window)))) 3329 (read-key (propertize (if (memq answer scroll-actions) 3330 prompt 3331 (concat "Please answer y or n. " 3332 prompt)) 3333 'face 'minibuffer-prompt))))) 3334 (setq answer (lookup-key query-replace-map (vector key) t)) 3335 (cond 3336 ((memq answer '(skip act)) nil) 3337 ((eq answer 'recenter) 3338 (recenter) t) 3339 ((eq answer 'scroll-up) 3340 (ignore-errors (scroll-up-command)) t) 3341 ((eq answer 'scroll-down) 3342 (ignore-errors (scroll-down-command)) t) 3343 ((eq answer 'scroll-other-window) 3344 (ignore-errors (scroll-other-window)) t) 3345 ((eq answer 'scroll-other-window-down) 3346 (ignore-errors (scroll-other-window-down)) t) 3347 ((or (memq answer '(exit-prefix quit)) (eq key ?\e)) 3348 (signal 'quit nil) t) 3349 (t t))) 3350 (ding) 3351 (discard-input))) 3352 (t 3353 (setq prompt (funcall padded prompt)) 3354 (defvar empty-history) 3355 (let* ((empty-history '()) 3356 (enable-recursive-minibuffers t) 3357 (msg help-form) 3358 (keymap (let ((map (make-composed-keymap 3359 y-or-n-p-map query-replace-map))) 3360 (when help-form 3361 ;; Create a new map before modifying 3362 (setq map (copy-keymap map)) 3363 (define-key map (vector help-char) 3364 (lambda () 3365 (interactive) 3366 (let ((help-form msg)) ; lexically bound msg 3367 (help-form-show))))) 3368 map)) 3369 ;; Protect this-command when called from pre-command-hook (bug#45029) 3370 (this-command this-command) 3371 (str (read-from-minibuffer 3372 prompt nil keymap nil 3373 (or y-or-n-p-history-variable 'empty-history)))) 3374 (setq answer (if (member str '("y" "Y")) 'act 'skip))))) 3375 (let ((ret (eq answer 'act))) 3376 (unless noninteractive 3377 (message "%s%c" prompt (if ret ?y ?n))) 3378 ret))) 3379 3380 3381;;; Atomic change groups. 3382 3383(defmacro atomic-change-group (&rest body) 3384 "Like `progn' but perform BODY as an atomic change group. 3385This means that if BODY exits abnormally, 3386all of its changes to the current buffer are undone. 3387This works regardless of whether undo is enabled in the buffer. 3388 3389This mechanism is transparent to ordinary use of undo; 3390if undo is enabled in the buffer and BODY succeeds, the 3391user can undo the change normally." 3392 (declare (indent 0) (debug t)) 3393 (let ((handle (make-symbol "--change-group-handle--")) 3394 (success (make-symbol "--change-group-success--"))) 3395 `(let ((,handle (prepare-change-group)) 3396 ;; Don't truncate any undo data in the middle of this. 3397 (undo-outer-limit nil) 3398 (undo-limit most-positive-fixnum) 3399 (undo-strong-limit most-positive-fixnum) 3400 (,success nil)) 3401 (unwind-protect 3402 (progn 3403 ;; This is inside the unwind-protect because 3404 ;; it enables undo if that was disabled; we need 3405 ;; to make sure that it gets disabled again. 3406 (activate-change-group ,handle) 3407 (prog1 ,(macroexp-progn body) 3408 (setq ,success t))) 3409 ;; Either of these functions will disable undo 3410 ;; if it was disabled before. 3411 (if ,success 3412 (accept-change-group ,handle) 3413 (cancel-change-group ,handle)))))) 3414 3415(defmacro with-undo-amalgamate (&rest body) 3416 "Like `progn' but perform BODY with amalgamated undo barriers. 3417 3418This allows multiple operations to be undone in a single step. 3419When undo is disabled this behaves like `progn'." 3420 (declare (indent 0) (debug t)) 3421 (let ((handle (make-symbol "--change-group-handle--"))) 3422 `(let ((,handle (prepare-change-group)) 3423 ;; Don't truncate any undo data in the middle of this, 3424 ;; otherwise Emacs might truncate part of the resulting 3425 ;; undo step: we want to mimic the behavior we'd get if the 3426 ;; undo-boundaries were never added in the first place. 3427 (undo-outer-limit nil) 3428 (undo-limit most-positive-fixnum) 3429 (undo-strong-limit most-positive-fixnum)) 3430 (unwind-protect 3431 (progn 3432 (activate-change-group ,handle) 3433 ,@body) 3434 (progn 3435 (accept-change-group ,handle) 3436 (undo-amalgamate-change-group ,handle)))))) 3437 3438(defun prepare-change-group (&optional buffer) 3439 "Return a handle for the current buffer's state, for a change group. 3440If you specify BUFFER, make a handle for BUFFER's state instead. 3441 3442Pass the handle to `activate-change-group' afterward to initiate 3443the actual changes of the change group. 3444 3445To finish the change group, call either `accept-change-group' or 3446`cancel-change-group' passing the same handle as argument. Call 3447`accept-change-group' to accept the changes in the group as final; 3448call `cancel-change-group' to undo them all. You should use 3449`unwind-protect' to make sure the group is always finished. The call 3450to `activate-change-group' should be inside the `unwind-protect'. 3451Once you finish the group, don't use the handle again--don't try to 3452finish the same group twice. For a simple example of correct use, see 3453the source code of `atomic-change-group'. 3454 3455The handle records only the specified buffer. To make a multibuffer 3456change group, call this function once for each buffer you want to 3457cover, then use `nconc' to combine the returned values, like this: 3458 3459 (nconc (prepare-change-group buffer-1) 3460 (prepare-change-group buffer-2)) 3461 3462You can then activate that multibuffer change group with a single 3463call to `activate-change-group' and finish it with a single call 3464to `accept-change-group' or `cancel-change-group'." 3465 3466 (if buffer 3467 (list (cons buffer (with-current-buffer buffer buffer-undo-list))) 3468 (list (cons (current-buffer) buffer-undo-list)))) 3469 3470(defun activate-change-group (handle) 3471 "Activate a change group made with `prepare-change-group' (which see)." 3472 (dolist (elt handle) 3473 (with-current-buffer (car elt) 3474 (if (eq buffer-undo-list t) 3475 (setq buffer-undo-list nil) 3476 ;; Add a boundary to make sure the upcoming changes won't be 3477 ;; merged/combined with any previous changes (bug#33341). 3478 ;; We're not supposed to introduce a real (visible) 3479 ;; `undo-boundary', tho, so we have to push something else 3480 ;; that acts like a boundary w.r.t preventing merges while 3481 ;; being harmless. 3482 ;; We use for that an "empty insertion", but in order to be harmless, 3483 ;; it has to be at a harmless position. Currently only 3484 ;; insertions are ever merged/combined, so we use such a "boundary" 3485 ;; only when the last change was an insertion and we use the position 3486 ;; of the last insertion. 3487 (when (numberp (car-safe (car buffer-undo-list))) 3488 (push (cons (caar buffer-undo-list) (caar buffer-undo-list)) 3489 buffer-undo-list)))))) 3490 3491(defun accept-change-group (handle) 3492 "Finish a change group made with `prepare-change-group' (which see). 3493This finishes the change group by accepting its changes as final." 3494 (dolist (elt handle) 3495 (with-current-buffer (car elt) 3496 (if (eq (cdr elt) t) 3497 (setq buffer-undo-list t))))) 3498 3499(defun cancel-change-group (handle) 3500 "Finish a change group made with `prepare-change-group' (which see). 3501This finishes the change group by reverting all of its changes." 3502 (dolist (elt handle) 3503 (with-current-buffer (car elt) 3504 (setq elt (cdr elt)) 3505 (save-restriction 3506 ;; Widen buffer temporarily so if the buffer was narrowed within 3507 ;; the body of `atomic-change-group' all changes can be undone. 3508 (widen) 3509 (let ((old-car (car-safe elt)) 3510 (old-cdr (cdr-safe elt)) 3511 ;; Use `pending-undo-list' temporarily since `undo-more' needs 3512 ;; it, but restore it afterwards so as not to mess with an 3513 ;; ongoing sequence of `undo's. 3514 (pending-undo-list 3515 ;; Use `buffer-undo-list' unconditionally (bug#39680). 3516 buffer-undo-list)) 3517 (unwind-protect 3518 (progn 3519 ;; Temporarily truncate the undo log at ELT. 3520 (when (consp elt) 3521 (setcar elt nil) (setcdr elt nil)) 3522 ;; Make sure there's no confusion. 3523 (when (and (consp elt) (not (eq elt (last pending-undo-list)))) 3524 (error "Undoing to some unrelated state")) 3525 ;; Undo it all. 3526 (save-excursion 3527 (while (listp pending-undo-list) (undo-more 1))) 3528 ;; Revert the undo info to what it was when we grabbed 3529 ;; the state. 3530 (setq buffer-undo-list elt)) 3531 ;; Reset the modified cons cell ELT to its original content. 3532 (when (consp elt) 3533 (setcar elt old-car) 3534 (setcdr elt old-cdr)))))))) 3535 3536;;;; Display-related functions. 3537 3538;; For compatibility. 3539(define-obsolete-function-alias 'redraw-modeline 3540 #'force-mode-line-update "24.3") 3541 3542(defun momentary-string-display (string pos &optional exit-char message) 3543 "Momentarily display STRING in the buffer at POS. 3544Display remains until next event is input. 3545If POS is a marker, only its position is used; its buffer is ignored. 3546Optional third arg EXIT-CHAR can be a character, event or event 3547description list. EXIT-CHAR defaults to SPC. If the input is 3548EXIT-CHAR it is swallowed; otherwise it is then available as 3549input (as a command if nothing else). 3550Display MESSAGE (optional fourth arg) in the echo area. 3551If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." 3552 (or exit-char (setq exit-char ?\s)) 3553 (let ((ol (make-overlay pos pos)) 3554 (str (copy-sequence string))) 3555 (unwind-protect 3556 (progn 3557 (save-excursion 3558 (overlay-put ol 'after-string str) 3559 (goto-char pos) 3560 ;; To avoid trouble with out-of-bounds position 3561 (setq pos (point)) 3562 ;; If the string end is off screen, recenter now. 3563 (if (<= (window-end nil t) pos) 3564 (recenter (/ (window-height) 2)))) 3565 (message (or message "Type %s to continue editing.") 3566 (single-key-description exit-char)) 3567 (let ((event (read-key))) 3568 ;; `exit-char' can be an event, or an event description list. 3569 (or (eq event exit-char) 3570 (eq event (event-convert-list exit-char)) 3571 (setq unread-command-events 3572 (append (this-single-command-raw-keys) 3573 unread-command-events))))) 3574 (delete-overlay ol)))) 3575 3576 3577;;;; Overlay operations 3578 3579(defun copy-overlay (o) 3580 "Return a copy of overlay O." 3581 (let ((o1 (if (overlay-buffer o) 3582 (make-overlay (overlay-start o) (overlay-end o) 3583 ;; FIXME: there's no easy way to find the 3584 ;; insertion-type of the two markers. 3585 (overlay-buffer o)) 3586 (let ((o1 (make-overlay (point-min) (point-min)))) 3587 (delete-overlay o1) 3588 o1))) 3589 (props (overlay-properties o))) 3590 (while props 3591 (overlay-put o1 (pop props) (pop props))) 3592 o1)) 3593 3594(defun remove-overlays (&optional beg end name val) 3595 "Remove overlays between BEG and END that have property NAME with value VAL. 3596Overlays might be moved and/or split. If any targeted overlays 3597start before BEG, the overlays will be altered so that they end 3598at BEG. Likewise, if the targeted overlays end after END, they 3599will be altered so that they start at END. Overlays that start 3600at or after BEG and end before END will be removed completely. 3601 3602BEG and END default respectively to the beginning and end of the 3603buffer. 3604Values are compared with `eq'. 3605If either NAME or VAL are specified, both should be specified." 3606 ;; This speeds up the loops over overlays. 3607 (unless beg (setq beg (point-min))) 3608 (unless end (setq end (point-max))) 3609 (overlay-recenter end) 3610 (if (< end beg) 3611 (setq beg (prog1 end (setq end beg)))) 3612 (save-excursion 3613 (dolist (o (overlays-in beg end)) 3614 (when (eq (overlay-get o name) val) 3615 ;; Either push this overlay outside beg...end 3616 ;; or split it to exclude beg...end 3617 ;; or delete it entirely (if it is contained in beg...end). 3618 (if (< (overlay-start o) beg) 3619 (if (> (overlay-end o) end) 3620 (progn 3621 (move-overlay (copy-overlay o) 3622 (overlay-start o) beg) 3623 (move-overlay o end (overlay-end o))) 3624 (move-overlay o (overlay-start o) beg)) 3625 (if (> (overlay-end o) end) 3626 (move-overlay o end (overlay-end o)) 3627 (delete-overlay o))))))) 3628 3629;;;; Miscellanea. 3630 3631(defvar suspend-hook nil 3632 "Normal hook run by `suspend-emacs', before suspending.") 3633 3634(defvar suspend-resume-hook nil 3635 "Normal hook run by `suspend-emacs', after Emacs is continued.") 3636 3637(defvar after-pdump-load-hook nil 3638 "Normal hook run after loading the .pdmp file.") 3639 3640(defvar temp-buffer-show-hook nil 3641 "Normal hook run by `with-output-to-temp-buffer' after displaying the buffer. 3642When the hook runs, the temporary buffer is current, and the window it 3643was displayed in is selected.") 3644 3645(defvar temp-buffer-setup-hook nil 3646 "Normal hook run by `with-output-to-temp-buffer' at the start. 3647When the hook runs, the temporary buffer is current. 3648This hook is normally set up with a function to put the buffer in Help 3649mode.") 3650 3651(defvar user-emacs-directory 3652 ;; The value does not matter since Emacs sets this at startup. 3653 nil 3654 "Directory beneath which additional per-user Emacs-specific files are placed. 3655Various programs in Emacs store information in this directory. 3656Note that this should end with a directory separator. 3657See also `locate-user-emacs-file'.") 3658 3659;;;; Misc. useful functions. 3660 3661(defsubst buffer-narrowed-p () 3662 "Return non-nil if the current buffer is narrowed." 3663 (/= (- (point-max) (point-min)) (buffer-size))) 3664 3665(defun find-tag-default-bounds () 3666 "Determine the boundaries of the default tag, based on text at point. 3667Return a cons cell with the beginning and end of the found tag. 3668If there is no plausible default, return nil." 3669 (bounds-of-thing-at-point 'symbol)) 3670 3671(defun find-tag-default () 3672 "Determine default tag to search for, based on text at point. 3673If there is no plausible default, return nil." 3674 (let ((bounds (find-tag-default-bounds))) 3675 (when bounds 3676 (buffer-substring-no-properties (car bounds) (cdr bounds))))) 3677 3678(defun find-tag-default-as-regexp () 3679 "Return regexp that matches the default tag at point. 3680If there is no tag at point, return nil. 3681 3682When in a major mode that does not provide its own 3683`find-tag-default-function', return a regexp that matches the 3684symbol at point exactly." 3685 (let ((tag (funcall (or find-tag-default-function 3686 (get major-mode 'find-tag-default-function) 3687 #'find-tag-default)))) 3688 (if tag (regexp-quote tag)))) 3689 3690(defun find-tag-default-as-symbol-regexp () 3691 "Return regexp that matches the default tag at point as symbol. 3692If there is no tag at point, return nil. 3693 3694When in a major mode that does not provide its own 3695`find-tag-default-function', return a regexp that matches the 3696symbol at point exactly." 3697 (let ((tag-regexp (find-tag-default-as-regexp))) 3698 (if (and tag-regexp 3699 (eq (or find-tag-default-function 3700 (get major-mode 'find-tag-default-function) 3701 #'find-tag-default) 3702 #'find-tag-default)) 3703 (format "\\_<%s\\_>" tag-regexp) 3704 tag-regexp))) 3705 3706(defun play-sound (sound) 3707 "SOUND is a list of the form `(sound KEYWORD VALUE...)'. 3708The following keywords are recognized: 3709 3710 :file FILE - read sound data from FILE. If FILE isn't an 3711absolute file name, it is searched in `data-directory'. 3712 3713 :data DATA - read sound data from string DATA. 3714 3715Exactly one of :file or :data must be present. 3716 3717 :volume VOL - set volume to VOL. VOL must an integer in the 3718range 0..100 or a float in the range 0..1.0. If not specified, 3719don't change the volume setting of the sound device. 3720 3721 :device DEVICE - play sound on DEVICE. If not specified, 3722a system-dependent default device name is used. 3723 3724Note: :data and :device are currently not supported on Windows." 3725 (if (fboundp 'play-sound-internal) 3726 (play-sound-internal sound) 3727 (error "This Emacs binary lacks sound support"))) 3728 3729(declare-function w32-shell-dos-semantics "w32-fns" nil) 3730 3731(defun shell-quote-argument (argument) 3732 "Quote ARGUMENT for passing as argument to an inferior shell. 3733 3734This function is designed to work with the syntax of your system's 3735standard shell, and might produce incorrect results with unusual shells. 3736See Info node `(elisp)Security Considerations'." 3737 (cond 3738 ((eq system-type 'ms-dos) 3739 ;; Quote using double quotes, but escape any existing quotes in 3740 ;; the argument with backslashes. 3741 (let ((result "") 3742 (start 0) 3743 end) 3744 (if (or (null (string-match "[^\"]" argument)) 3745 (< (match-end 0) (length argument))) 3746 (while (string-match "[\"]" argument start) 3747 (setq end (match-beginning 0) 3748 result (concat result (substring argument start end) 3749 "\\" (substring argument end (1+ end))) 3750 start (1+ end)))) 3751 (concat "\"" result (substring argument start) "\""))) 3752 3753 ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics)) 3754 3755 ;; First, quote argument so that CommandLineToArgvW will 3756 ;; understand it. See 3757 ;; https://msdn.microsoft.com/en-us/library/17w5ykft%28v=vs.85%29.aspx 3758 ;; After we perform that level of quoting, escape shell 3759 ;; metacharacters so that cmd won't mangle our argument. If the 3760 ;; argument contains no double quote characters, we can just 3761 ;; surround it with double quotes. Otherwise, we need to prefix 3762 ;; each shell metacharacter with a caret. 3763 3764 (setq argument 3765 ;; escape backslashes at end of string 3766 (replace-regexp-in-string 3767 "\\(\\\\*\\)$" 3768 "\\1\\1" 3769 ;; escape backslashes and quotes in string body 3770 (replace-regexp-in-string 3771 "\\(\\\\*\\)\"" 3772 "\\1\\1\\\\\"" 3773 argument))) 3774 3775 (if (string-match "[%!\"]" argument) 3776 (concat 3777 "^\"" 3778 (replace-regexp-in-string 3779 "\\([%!()\"<>&|^]\\)" 3780 "^\\1" 3781 argument) 3782 "^\"") 3783 (concat "\"" argument "\""))) 3784 3785 (t 3786 (if (equal argument "") 3787 "''" 3788 ;; Quote everything except POSIX filename characters. 3789 ;; This should be safe enough even for really weird shells. 3790 (string-replace 3791 "\n" "'\n'" 3792 (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument)))) 3793 )) 3794 3795(defsubst string-to-list (string) 3796 "Return a list of characters in STRING." 3797 (append string nil)) 3798 3799(defsubst string-to-vector (string) 3800 "Return a vector of characters in STRING." 3801 (vconcat string)) 3802 3803(defun string-or-null-p (object) 3804 "Return t if OBJECT is a string or nil. 3805Otherwise, return nil." 3806 (or (stringp object) (null object))) 3807 3808(defun booleanp (object) 3809 "Return t if OBJECT is one of the two canonical boolean values: t or nil. 3810Otherwise, return nil." 3811 (and (memq object '(nil t)) t)) 3812 3813(defun special-form-p (object) 3814 "Non-nil if and only if OBJECT is a special form." 3815 (if (and (symbolp object) (fboundp object)) 3816 (setq object (indirect-function object))) 3817 (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled))) 3818 3819(defun macrop (object) 3820 "Non-nil if and only if OBJECT is a macro." 3821 (let ((def (indirect-function object))) 3822 (when (consp def) 3823 (or (eq 'macro (car def)) 3824 (and (autoloadp def) (memq (nth 4 def) '(macro t))))))) 3825 3826(defun field-at-pos (pos) 3827 "Return the field at position POS, taking stickiness etc into account." 3828 (let ((raw-field (get-char-property (field-beginning pos) 'field))) 3829 (if (eq raw-field 'boundary) 3830 (get-char-property (1- (field-end pos)) 'field) 3831 raw-field))) 3832 3833(defun sha1 (object &optional start end binary) 3834 "Return the SHA-1 (Secure Hash Algorithm) of an OBJECT. 3835OBJECT is either a string or a buffer. Optional arguments START and 3836END are character positions specifying which portion of OBJECT for 3837computing the hash. If BINARY is non-nil, return a string in binary 3838form. 3839 3840Note that SHA-1 is not collision resistant and should not be used 3841for anything security-related. See `secure-hash' for 3842alternatives." 3843 (secure-hash 'sha1 object start end binary)) 3844 3845(defun function-get (f prop &optional autoload) 3846 "Return the value of property PROP of function F. 3847If AUTOLOAD is non-nil and F is autoloaded, try to load it 3848in the hope that it will set PROP. If AUTOLOAD is `macro', do it only 3849if it's an autoloaded macro." 3850 (let ((val nil)) 3851 (while (and (symbolp f) 3852 (null (setq val (get f prop))) 3853 (fboundp f)) 3854 (let ((fundef (symbol-function f))) 3855 (if (and autoload (autoloadp fundef) 3856 (not (equal fundef 3857 (autoload-do-load fundef f 3858 (if (eq autoload 'macro) 3859 'macro))))) 3860 nil ;Re-try `get' on the same `f'. 3861 (setq f fundef)))) 3862 val)) 3863 3864;;;; Support for yanking and text properties. 3865;; Why here in subr.el rather than in simple.el? --Stef 3866 3867(defvar yank-handled-properties) 3868(defvar yank-excluded-properties) 3869 3870(defun remove-yank-excluded-properties (start end) 3871 "Process text properties between START and END, inserted for a `yank'. 3872Perform the handling specified by `yank-handled-properties', then 3873remove properties specified by `yank-excluded-properties'." 3874 (let ((inhibit-read-only t)) 3875 (dolist (handler yank-handled-properties) 3876 (let ((prop (car handler)) 3877 (fun (cdr handler)) 3878 (run-start start)) 3879 (while (< run-start end) 3880 (let ((value (get-text-property run-start prop)) 3881 (run-end (next-single-property-change 3882 run-start prop nil end))) 3883 (funcall fun value run-start run-end) 3884 (setq run-start run-end))))) 3885 (if (eq yank-excluded-properties t) 3886 (set-text-properties start end nil) 3887 (remove-list-of-text-properties start end yank-excluded-properties)))) 3888 3889(defvar yank-undo-function) 3890 3891(defun insert-for-yank (string) 3892 "Insert STRING at point for the `yank' command. 3893 3894This function is like `insert', except it honors the variables 3895`yank-handled-properties' and `yank-excluded-properties', and the 3896`yank-handler' text property, in the way that `yank' does." 3897 (let (to) 3898 (while (setq to (next-single-property-change 0 'yank-handler string)) 3899 (insert-for-yank-1 (substring string 0 to)) 3900 (setq string (substring string to)))) 3901 (insert-for-yank-1 string)) 3902 3903(defun insert-for-yank-1 (string) 3904 "Helper for `insert-for-yank', which see." 3905 (let* ((handler (and (stringp string) 3906 (get-text-property 0 'yank-handler string))) 3907 (param (or (nth 1 handler) string)) 3908 (opoint (point)) 3909 (inhibit-read-only inhibit-read-only) 3910 end) 3911 3912 ;; FIXME: This throws away any yank-undo-function set by previous calls 3913 ;; to insert-for-yank-1 within the loop of insert-for-yank! 3914 (setq yank-undo-function t) 3915 (if (nth 0 handler) ; FUNCTION 3916 (funcall (car handler) param) 3917 (insert param)) 3918 (setq end (point)) 3919 3920 ;; Prevent read-only properties from interfering with the 3921 ;; following text property changes. 3922 (setq inhibit-read-only t) 3923 3924 (unless (nth 2 handler) ; NOEXCLUDE 3925 (remove-yank-excluded-properties opoint end)) 3926 3927 ;; If last inserted char has properties, mark them as rear-nonsticky. 3928 (if (and (> end opoint) 3929 (text-properties-at (1- end))) 3930 (put-text-property (1- end) end 'rear-nonsticky t)) 3931 3932 (if (eq yank-undo-function t) ; not set by FUNCTION 3933 (setq yank-undo-function (nth 3 handler))) ; UNDO 3934 (if (nth 4 handler) ; COMMAND 3935 (setq this-command (nth 4 handler))))) 3936 3937(defun insert-buffer-substring-no-properties (buffer &optional start end) 3938 "Insert before point a substring of BUFFER, without text properties. 3939BUFFER may be a buffer or a buffer name. 3940Arguments START and END are character positions specifying the substring. 3941They default to the values of (point-min) and (point-max) in BUFFER." 3942 (let ((opoint (point))) 3943 (insert-buffer-substring buffer start end) 3944 (let ((inhibit-read-only t)) 3945 (set-text-properties opoint (point) nil)))) 3946 3947(defun insert-buffer-substring-as-yank (buffer &optional start end) 3948 "Insert before point a part of BUFFER, stripping some text properties. 3949BUFFER may be a buffer or a buffer name. 3950Arguments START and END are character positions specifying the substring. 3951They default to the values of (point-min) and (point-max) in BUFFER. 3952Before insertion, process text properties according to 3953`yank-handled-properties' and `yank-excluded-properties'." 3954 ;; Since the buffer text should not normally have yank-handler properties, 3955 ;; there is no need to handle them here. 3956 (let ((opoint (point))) 3957 (insert-buffer-substring buffer start end) 3958 (remove-yank-excluded-properties opoint (point)))) 3959 3960(defun insert-into-buffer (buffer &optional start end) 3961 "Insert the contents of the current buffer into BUFFER. 3962If START/END, only insert that region from the current buffer. 3963Point in BUFFER will be placed after the inserted text." 3964 (let ((current (current-buffer))) 3965 (with-current-buffer buffer 3966 (insert-buffer-substring current start end)))) 3967 3968(defun replace-string-in-region (string replacement &optional start end) 3969 "Replace STRING with REPLACEMENT in the region from START to END. 3970The number of replaced occurrences are returned, or nil if STRING 3971doesn't exist in the region. 3972 3973If START is nil, use the current point. If END is nil, use `point-max'. 3974 3975Comparisons and replacements are done with fixed case." 3976 (if start 3977 (when (< start (point-min)) 3978 (error "Start before start of buffer")) 3979 (setq start (point))) 3980 (if end 3981 (when (> end (point-max)) 3982 (error "End after end of buffer")) 3983 (setq end (point-max))) 3984 (save-excursion 3985 (let ((matches 0) 3986 (case-fold-search nil)) 3987 (goto-char start) 3988 (while (search-forward string end t) 3989 (delete-region (match-beginning 0) (match-end 0)) 3990 (insert replacement) 3991 (setq matches (1+ matches))) 3992 (and (not (zerop matches)) 3993 matches)))) 3994 3995(defun replace-regexp-in-region (regexp replacement &optional start end) 3996 "Replace REGEXP with REPLACEMENT in the region from START to END. 3997The number of replaced occurrences are returned, or nil if REGEXP 3998doesn't exist in the region. 3999 4000If START is nil, use the current point. If END is nil, use `point-max'. 4001 4002Comparisons and replacements are done with fixed case. 4003 4004REPLACEMENT can use the following special elements: 4005 4006 `\\&' in NEWTEXT means substitute original matched text. 4007 `\\N' means substitute what matched the Nth `\\(...\\)'. 4008 If Nth parens didn't match, substitute nothing. 4009 `\\\\' means insert one `\\'. 4010 `\\?' is treated literally." 4011 (if start 4012 (when (< start (point-min)) 4013 (error "Start before start of buffer")) 4014 (setq start (point))) 4015 (if end 4016 (when (> end (point-max)) 4017 (error "End after end of buffer")) 4018 (setq end (point-max))) 4019 (save-excursion 4020 (let ((matches 0) 4021 (case-fold-search nil)) 4022 (goto-char start) 4023 (while (re-search-forward regexp end t) 4024 (replace-match replacement t) 4025 (setq matches (1+ matches))) 4026 (and (not (zerop matches)) 4027 matches)))) 4028 4029(defun yank-handle-font-lock-face-property (face start end) 4030 "If `font-lock-defaults' is nil, apply FACE as a `face' property. 4031START and END denote the start and end of the text to act on. 4032Do nothing if FACE is nil." 4033 (and face 4034 (null font-lock-defaults) 4035 (put-text-property start end 'face face))) 4036 4037;; This removes `mouse-face' properties in *Help* buffer buttons: 4038;; https://lists.gnu.org/r/emacs-devel/2002-04/msg00648.html 4039(defun yank-handle-category-property (category start end) 4040 "Apply property category CATEGORY's properties between START and END." 4041 (when category 4042 (let ((start2 start)) 4043 (while (< start2 end) 4044 (let ((end2 (next-property-change start2 nil end)) 4045 (original (text-properties-at start2))) 4046 (set-text-properties start2 end2 (symbol-plist category)) 4047 (add-text-properties start2 end2 original) 4048 (setq start2 end2)))))) 4049 4050 4051;;;; Synchronous shell commands. 4052 4053(defun start-process-shell-command (name buffer command) 4054 "Start a program in a subprocess. Return the process object for it. 4055NAME is name for process. It is modified if necessary to make it unique. 4056BUFFER is the buffer (or buffer name) to associate with the process. 4057 Process output goes at end of that buffer, unless you specify 4058 an output stream or filter function to handle the output. 4059 BUFFER may be also nil, meaning that this process is not associated 4060 with any buffer. 4061COMMAND is the shell command to run." 4062 ;; We used to use `exec' to replace the shell with the command, 4063 ;; but that failed to handle (...) and semicolon, etc. 4064 (start-process name buffer shell-file-name shell-command-switch command)) 4065 4066(defun start-file-process-shell-command (name buffer command) 4067 "Start a program in a subprocess. Return the process object for it. 4068Similar to `start-process-shell-command', but calls `start-file-process'." 4069 ;; On remote hosts, the local `shell-file-name' might be useless. 4070 (with-connection-local-variables 4071 (start-file-process 4072 name buffer shell-file-name shell-command-switch command))) 4073 4074(defun call-process-shell-command (command &optional infile buffer display 4075 &rest args) 4076 "Execute the shell command COMMAND synchronously in separate process. 4077The remaining arguments are optional. 4078The program's input comes from file INFILE (nil means `/dev/null'). 4079Insert output in BUFFER before point; t means current buffer; 4080 nil for BUFFER means discard it; 0 means discard and don't wait. 4081BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case, 4082REAL-BUFFER says what to do with standard output, as above, 4083while STDERR-FILE says what to do with standard error in the child. 4084STDERR-FILE may be nil (discard standard error output), 4085t (mix it with ordinary output), or a file name string. 4086 4087Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted. 4088Wildcards and redirection are handled as usual in the shell. 4089 4090If BUFFER is 0, `call-process-shell-command' returns immediately with value nil. 4091Otherwise it waits for COMMAND to terminate and returns a numeric exit 4092status or a signal description string. 4093If you quit, the process is killed with SIGINT, or SIGKILL if you quit again. 4094 4095An old calling convention accepted any number of arguments after DISPLAY, 4096which were just concatenated to COMMAND. This is still supported but strongly 4097discouraged." 4098 (declare (advertised-calling-convention 4099 (command &optional infile buffer display) "24.5")) 4100 ;; We used to use `exec' to replace the shell with the command, 4101 ;; but that failed to handle (...) and semicolon, etc. 4102 (call-process shell-file-name 4103 infile buffer display 4104 shell-command-switch 4105 (mapconcat #'identity (cons command args) " "))) 4106 4107(defun process-file-shell-command (command &optional infile buffer display 4108 &rest args) 4109 "Process files synchronously in a separate process. 4110Similar to `call-process-shell-command', but calls `process-file'." 4111 (declare (advertised-calling-convention 4112 (command &optional infile buffer display) "24.5")) 4113 ;; On remote hosts, the local `shell-file-name' might be useless. 4114 (with-connection-local-variables 4115 (process-file 4116 shell-file-name infile buffer display shell-command-switch 4117 (mapconcat #'identity (cons command args) " ")))) 4118 4119(defun call-shell-region (start end command &optional delete buffer) 4120 "Send text from START to END as input to an inferior shell running COMMAND. 4121Delete the text if fourth arg DELETE is non-nil. 4122 4123Insert output in BUFFER before point; t means current buffer; nil for 4124 BUFFER means discard it; 0 means discard and don't wait; and `(:file 4125 FILE)', where FILE is a file name string, means that it should be 4126 written to that file (if the file already exists it is overwritten). 4127BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case, 4128REAL-BUFFER says what to do with standard output, as above, 4129while STDERR-FILE says what to do with standard error in the child. 4130STDERR-FILE may be nil (discard standard error output), 4131t (mix it with ordinary output), or a file name string. 4132 4133If BUFFER is 0, `call-shell-region' returns immediately with value nil. 4134Otherwise it waits for COMMAND to terminate 4135and returns a numeric exit status or a signal description string. 4136If you quit, the process is killed with SIGINT, or SIGKILL if you quit again." 4137 (call-process-region start end 4138 shell-file-name delete buffer nil 4139 shell-command-switch command)) 4140 4141;;;; Lisp macros to do various things temporarily. 4142 4143(defmacro track-mouse (&rest body) 4144 "Evaluate BODY with mouse movement events enabled. 4145Within a `track-mouse' form, mouse motion generates input events that 4146 you can read with `read-event'. 4147Normally, mouse motion is ignored." 4148 (declare (debug (def-body)) (indent 0)) 4149 `(internal--track-mouse (lambda () ,@body))) 4150 4151(defmacro with-current-buffer (buffer-or-name &rest body) 4152 "Execute the forms in BODY with BUFFER-OR-NAME temporarily current. 4153BUFFER-OR-NAME must be a buffer or the name of an existing buffer. 4154The value returned is the value of the last form in BODY. See 4155also `with-temp-buffer'." 4156 (declare (indent 1) (debug t)) 4157 `(save-current-buffer 4158 (set-buffer ,buffer-or-name) 4159 ,@body)) 4160 4161(defun internal--before-with-selected-window (window) 4162 (let ((other-frame (window-frame window))) 4163 (list window (selected-window) 4164 ;; Selecting a window on another frame also changes that 4165 ;; frame's frame-selected-window. We must save&restore it. 4166 (unless (eq (selected-frame) other-frame) 4167 (frame-selected-window other-frame)) 4168 ;; Also remember the top-frame if on ttys. 4169 (unless (eq (selected-frame) other-frame) 4170 (tty-top-frame other-frame))))) 4171 4172(defun internal--after-with-selected-window (state) 4173 ;; First reset frame-selected-window. 4174 (when (window-live-p (nth 2 state)) 4175 ;; We don't use set-frame-selected-window because it does not 4176 ;; pass the `norecord' argument to Fselect_window. 4177 (select-window (nth 2 state) 'norecord) 4178 (and (frame-live-p (nth 3 state)) 4179 (not (eq (tty-top-frame) (nth 3 state))) 4180 (select-frame (nth 3 state) 'norecord))) 4181 ;; Then reset the actual selected-window. 4182 (when (window-live-p (nth 1 state)) 4183 (select-window (nth 1 state) 'norecord))) 4184 4185(defun generate-new-buffer (name &optional inhibit-buffer-hooks) 4186 "Create and return a buffer with a name based on NAME. 4187Choose the buffer's name using `generate-new-buffer-name'. 4188See `get-buffer-create' for the meaning of INHIBIT-BUFFER-HOOKS." 4189 (get-buffer-create (generate-new-buffer-name name) inhibit-buffer-hooks)) 4190 4191(defmacro with-selected-window (window &rest body) 4192 "Execute the forms in BODY with WINDOW as the selected window. 4193The value returned is the value of the last form in BODY. 4194 4195This macro saves and restores the selected window, as well as the 4196selected window of each frame. It does not change the order of 4197recently selected windows. If the previously selected window of 4198some frame is no longer live at the end of BODY, that frame's 4199selected window is left alone. If the selected window is no 4200longer live, then whatever window is selected at the end of BODY 4201remains selected. 4202 4203This macro uses `save-current-buffer' to save and restore the 4204current buffer, since otherwise its normal operation could 4205potentially make a different buffer current. It does not alter 4206the buffer list ordering." 4207 (declare (indent 1) (debug t)) 4208 `(let ((save-selected-window--state 4209 (internal--before-with-selected-window ,window))) 4210 (save-current-buffer 4211 (unwind-protect 4212 (progn (select-window (car save-selected-window--state) 'norecord) 4213 ,@body) 4214 (internal--after-with-selected-window save-selected-window--state))))) 4215 4216(defmacro with-selected-frame (frame &rest body) 4217 "Execute the forms in BODY with FRAME as the selected frame. 4218The value returned is the value of the last form in BODY. 4219 4220This macro saves and restores the selected frame, and changes the 4221order of neither the recently selected windows nor the buffers in 4222the buffer list." 4223 (declare (indent 1) (debug t)) 4224 (let ((old-frame (make-symbol "old-frame")) 4225 (old-buffer (make-symbol "old-buffer"))) 4226 `(let ((,old-frame (selected-frame)) 4227 (,old-buffer (current-buffer))) 4228 (unwind-protect 4229 (progn (select-frame ,frame 'norecord) 4230 ,@body) 4231 (when (frame-live-p ,old-frame) 4232 (select-frame ,old-frame 'norecord)) 4233 (when (buffer-live-p ,old-buffer) 4234 (set-buffer ,old-buffer)))))) 4235 4236(defmacro save-window-excursion (&rest body) 4237 "Execute BODY, then restore previous window configuration. 4238This macro saves the window configuration on the selected frame, 4239executes BODY, then calls `set-window-configuration' to restore 4240the saved window configuration. The return value is the last 4241form in BODY. The window configuration is also restored if BODY 4242exits nonlocally. 4243 4244BEWARE: Most uses of this macro introduce bugs. 4245E.g. it should not be used to try and prevent some code from opening 4246a new window, since that window may sometimes appear in another frame, 4247in which case `save-window-excursion' cannot help." 4248 (declare (indent 0) (debug t)) 4249 (let ((c (make-symbol "wconfig"))) 4250 `(let ((,c (current-window-configuration))) 4251 (unwind-protect (progn ,@body) 4252 (set-window-configuration ,c))))) 4253 4254(defun internal-temp-output-buffer-show (buffer) 4255 "Internal function for `with-output-to-temp-buffer'." 4256 (with-current-buffer buffer 4257 (set-buffer-modified-p nil) 4258 (goto-char (point-min))) 4259 4260 (if temp-buffer-show-function 4261 (funcall temp-buffer-show-function buffer) 4262 (with-current-buffer buffer 4263 (let* ((window 4264 (let ((window-combination-limit 4265 ;; When `window-combination-limit' equals 4266 ;; `temp-buffer' or `temp-buffer-resize' and 4267 ;; `temp-buffer-resize-mode' is enabled in this 4268 ;; buffer bind it to t so resizing steals space 4269 ;; preferably from the window that was split. 4270 (if (or (eq window-combination-limit 'temp-buffer) 4271 (and (eq window-combination-limit 4272 'temp-buffer-resize) 4273 temp-buffer-resize-mode)) 4274 t 4275 window-combination-limit))) 4276 (display-buffer buffer))) 4277 (frame (and window (window-frame window)))) 4278 (when window 4279 (unless (eq frame (selected-frame)) 4280 (make-frame-visible frame)) 4281 (setq minibuffer-scroll-window window) 4282 (set-window-hscroll window 0) 4283 ;; Don't try this with NOFORCE non-nil! 4284 (set-window-start window (point-min) t) 4285 ;; This should not be necessary. 4286 (set-window-point window (point-min)) 4287 ;; Run `temp-buffer-show-hook', with the chosen window selected. 4288 (with-selected-window window 4289 (run-hooks 'temp-buffer-show-hook)))))) 4290 ;; Return nil. 4291 nil) 4292 4293;; Doc is very similar to with-temp-buffer-window. 4294(defmacro with-output-to-temp-buffer (bufname &rest body) 4295 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. 4296 4297This construct makes buffer BUFNAME empty before running BODY. 4298It does not make the buffer current for BODY. 4299Instead it binds `standard-output' to that buffer, so that output 4300generated with `prin1' and similar functions in BODY goes into 4301the buffer. 4302 4303At the end of BODY, this marks buffer BUFNAME unmodified and displays 4304it in a window, but does not select it. The normal way to do this is 4305by calling `display-buffer', then running `temp-buffer-show-hook'. 4306However, if `temp-buffer-show-function' is non-nil, it calls that 4307function instead (and does not run `temp-buffer-show-hook'). The 4308function gets one argument, the buffer to display. 4309 4310The return value of `with-output-to-temp-buffer' is the value of the 4311last form in BODY. If BODY does not finish normally, the buffer 4312BUFNAME is not displayed. 4313 4314This runs the hook `temp-buffer-setup-hook' before BODY, 4315with the buffer BUFNAME temporarily current. It runs the hook 4316`temp-buffer-show-hook' after displaying buffer BUFNAME, with that 4317buffer temporarily current, and the window that was used to display it 4318temporarily selected. But it doesn't run `temp-buffer-show-hook' 4319if it uses `temp-buffer-show-function'. 4320 4321By default, the setup hook puts the buffer into Help mode before running BODY. 4322If BODY does not change the major mode, the show hook makes the buffer 4323read-only, and scans it for function and variable names to make them into 4324clickable cross-references. 4325 4326See the related form `with-temp-buffer-window'." 4327 (declare (debug t)) 4328 (let ((old-dir (make-symbol "old-dir")) 4329 (buf (make-symbol "buf"))) 4330 `(let* ((,old-dir default-directory) 4331 (,buf 4332 (with-current-buffer (get-buffer-create ,bufname) 4333 (prog1 (current-buffer) 4334 (kill-all-local-variables) 4335 ;; FIXME: delete_all_overlays 4336 (setq default-directory ,old-dir) 4337 (setq buffer-read-only nil) 4338 (setq buffer-file-name nil) 4339 (setq buffer-undo-list t) 4340 (let ((inhibit-read-only t) 4341 (inhibit-modification-hooks t)) 4342 (erase-buffer) 4343 (run-hooks 'temp-buffer-setup-hook))))) 4344 (standard-output ,buf)) 4345 (prog1 (progn ,@body) 4346 (internal-temp-output-buffer-show ,buf))))) 4347 4348(defmacro with-temp-file (file &rest body) 4349 "Create a new buffer, evaluate BODY there, and write the buffer to FILE. 4350The value returned is the value of the last form in BODY. 4351The buffer does not run the hooks `kill-buffer-hook', 4352`kill-buffer-query-functions', and `buffer-list-update-hook'. 4353See also `with-temp-buffer'." 4354 (declare (indent 1) (debug t)) 4355 (let ((temp-file (make-symbol "temp-file")) 4356 (temp-buffer (make-symbol "temp-buffer"))) 4357 `(let ((,temp-file ,file) 4358 (,temp-buffer (generate-new-buffer " *temp file*" t))) 4359 (unwind-protect 4360 (prog1 4361 (with-current-buffer ,temp-buffer 4362 ,@body) 4363 (with-current-buffer ,temp-buffer 4364 (write-region nil nil ,temp-file nil 0))) 4365 (and (buffer-name ,temp-buffer) 4366 (kill-buffer ,temp-buffer)))))) 4367 4368(defmacro with-temp-message (message &rest body) 4369 "Display MESSAGE temporarily if non-nil while BODY is evaluated. 4370The original message is restored to the echo area after BODY has finished. 4371The value returned is the value of the last form in BODY. 4372MESSAGE is written to the message log buffer if `message-log-max' is non-nil. 4373If MESSAGE is nil, the echo area and message log buffer are unchanged. 4374Use a MESSAGE of \"\" to temporarily clear the echo area." 4375 (declare (debug t) (indent 1)) 4376 (let ((current-message (make-symbol "current-message")) 4377 (temp-message (make-symbol "with-temp-message"))) 4378 `(let ((,temp-message ,message) 4379 (,current-message)) 4380 (unwind-protect 4381 (progn 4382 (when ,temp-message 4383 (setq ,current-message (current-message)) 4384 (message "%s" ,temp-message)) 4385 ,@body) 4386 (and ,temp-message 4387 (if ,current-message 4388 (message "%s" ,current-message) 4389 (message nil))))))) 4390 4391(defmacro with-temp-buffer (&rest body) 4392 "Create a temporary buffer, and evaluate BODY there like `progn'. 4393The buffer does not run the hooks `kill-buffer-hook', 4394`kill-buffer-query-functions', and `buffer-list-update-hook'. 4395See also `with-temp-file' and `with-output-to-string'." 4396 (declare (indent 0) (debug t)) 4397 (let ((temp-buffer (make-symbol "temp-buffer"))) 4398 `(let ((,temp-buffer (generate-new-buffer " *temp*" t))) 4399 ;; `kill-buffer' can change current-buffer in some odd cases. 4400 (with-current-buffer ,temp-buffer 4401 (unwind-protect 4402 (progn ,@body) 4403 (and (buffer-name ,temp-buffer) 4404 (kill-buffer ,temp-buffer))))))) 4405 4406(defmacro with-silent-modifications (&rest body) 4407 "Execute BODY, pretending it does not modify the buffer. 4408This macro is typically used around modifications of 4409text properties that do not really affect the buffer's content. 4410If BODY performs real modifications to the buffer's text, other 4411than cosmetic ones, undo data may become corrupted. 4412 4413This macro will run BODY normally, but doesn't count its buffer 4414modifications as being buffer modifications. This affects things 4415like `buffer-modified-p', checking whether the file is locked by 4416someone else, running buffer modification hooks, and other things 4417of that nature." 4418 (declare (debug t) (indent 0)) 4419 (let ((modified (make-symbol "modified"))) 4420 `(let* ((,modified (buffer-modified-p)) 4421 (buffer-undo-list t) 4422 (inhibit-read-only t) 4423 (inhibit-modification-hooks t)) 4424 (unwind-protect 4425 (progn 4426 ,@body) 4427 (unless ,modified 4428 (restore-buffer-modified-p nil)))))) 4429 4430(defmacro with-output-to-string (&rest body) 4431 "Execute BODY, return the text it sent to `standard-output', as a string." 4432 (declare (indent 0) (debug t)) 4433 `(let ((standard-output (generate-new-buffer " *string-output*" t))) 4434 (unwind-protect 4435 (progn 4436 (let ((standard-output standard-output)) 4437 ,@body) 4438 (with-current-buffer standard-output 4439 (buffer-string))) 4440 (kill-buffer standard-output)))) 4441 4442(defmacro with-local-quit (&rest body) 4443 "Execute BODY, allowing quits to terminate BODY but not escape further. 4444When a quit terminates BODY, `with-local-quit' returns nil but 4445requests another quit. That quit will be processed as soon as quitting 4446is allowed once again. (Immediately, if `inhibit-quit' is nil.)" 4447 (declare (debug t) (indent 0)) 4448 `(condition-case nil 4449 (let ((inhibit-quit nil)) 4450 ,@body) 4451 (quit (setq quit-flag t) 4452 ;; This call is to give a chance to handle quit-flag 4453 ;; in case inhibit-quit is nil. 4454 ;; Without this, it will not be handled until the next function 4455 ;; call, and that might allow it to exit thru a condition-case 4456 ;; that intends to handle the quit signal next time. 4457 (eval '(ignore nil))))) 4458 4459(defmacro while-no-input (&rest body) 4460 "Execute BODY only as long as there's no pending input. 4461If input arrives, that ends the execution of BODY, 4462and `while-no-input' returns t. Quitting makes it return nil. 4463If BODY finishes, `while-no-input' returns whatever value BODY produced." 4464 (declare (debug t) (indent 0)) 4465 (let ((catch-sym (make-symbol "input"))) 4466 `(with-local-quit 4467 (catch ',catch-sym 4468 (let ((throw-on-input ',catch-sym) 4469 val) 4470 (setq val (or (input-pending-p) 4471 (progn ,@body))) 4472 (cond 4473 ;; When input arrives while throw-on-input is non-nil, 4474 ;; kbd_buffer_store_buffered_event sets quit-flag to the 4475 ;; value of throw-on-input. If, when BODY finishes, 4476 ;; quit-flag still has the same value as throw-on-input, it 4477 ;; means BODY never tested quit-flag, and therefore ran to 4478 ;; completion even though input did arrive before it 4479 ;; finished. In that case, we must manually simulate what 4480 ;; 'throw' in process_quit_flag would do, and we must 4481 ;; reset quit-flag, because leaving it set will cause us 4482 ;; quit to top-level, which has undesirable consequences, 4483 ;; such as discarding input etc. We return t in that case 4484 ;; because input did arrive during execution of BODY. 4485 ((eq quit-flag throw-on-input) 4486 (setq quit-flag nil) 4487 t) 4488 ;; This is for when the user actually QUITs during 4489 ;; execution of BODY. 4490 (quit-flag 4491 nil) 4492 (t val))))))) 4493 4494(defmacro condition-case-unless-debug (var bodyform &rest handlers) 4495 "Like `condition-case' except that it does not prevent debugging. 4496More specifically if `debug-on-error' is set then the debugger will be invoked 4497even if this catches the signal." 4498 (declare (debug condition-case) (indent 2)) 4499 `(condition-case ,var 4500 ,bodyform 4501 ,@(mapcar (lambda (handler) 4502 `((debug ,@(if (listp (car handler)) (car handler) 4503 (list (car handler)))) 4504 ,@(cdr handler))) 4505 handlers))) 4506 4507(define-obsolete-function-alias 'condition-case-no-debug 4508 'condition-case-unless-debug "24.1") 4509 4510(defmacro with-demoted-errors (format &rest body) 4511 "Run BODY and demote any errors to simple messages. 4512FORMAT is a string passed to `message' to format any error message. 4513It should contain a single %-sequence; e.g., \"Error: %S\". 4514 4515If `debug-on-error' is non-nil, run BODY without catching its errors. 4516This is to be used around code that is not expected to signal an error 4517but that should be robust in the unexpected case that an error is signaled. 4518 4519For backward compatibility, if FORMAT is not a constant string, it 4520is assumed to be part of BODY, in which case the message format 4521used is \"Error: %S\"." 4522 (declare (debug t) (indent 1)) 4523 (let ((err (make-symbol "err")) 4524 (format (if (and (stringp format) body) format 4525 (prog1 "Error: %S" 4526 (if format (push format body)))))) 4527 `(condition-case-unless-debug ,err 4528 ,(macroexp-progn body) 4529 (error (message ,format ,err) nil)))) 4530 4531(defmacro combine-after-change-calls (&rest body) 4532 "Execute BODY, but don't call the after-change functions till the end. 4533If BODY makes changes in the buffer, they are recorded 4534and the functions on `after-change-functions' are called several times 4535when BODY is finished. 4536The return value is the value of the last form in BODY. 4537 4538If `before-change-functions' is non-nil, then calls to the after-change 4539functions can't be deferred, so in that case this macro has no effect. 4540 4541Do not alter `after-change-functions' or `before-change-functions' 4542in BODY." 4543 (declare (indent 0) (debug t)) 4544 `(unwind-protect 4545 (let ((combine-after-change-calls t)) 4546 . ,body) 4547 (combine-after-change-execute))) 4548 4549;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4550(defvar undo--combining-change-calls nil 4551 "Non-nil when `combine-change-calls-1' is running.") 4552 4553(defun combine-change-calls-1 (beg end body) 4554 "Evaluate BODY, running the change hooks just once, for region \(BEG END). 4555 4556Firstly, `before-change-functions' is invoked for the region 4557\(BEG END), then BODY (a function) is evaluated with 4558`before-change-functions' and `after-change-functions' bound to 4559nil, then finally `after-change-functions' is invoked on the 4560updated region (BEG NEW-END) with a calculated OLD-LEN argument. 4561If `inhibit-modification-hooks' is initially non-nil, the change 4562hooks are not run. 4563 4564The result of `combine-change-calls-1' is the value returned by 4565BODY. BODY must not make a different buffer current, except 4566temporarily. It must not make any changes to the buffer outside 4567the specified region. It must not change 4568`before-change-functions' or `after-change-functions'. 4569 4570Additionally, the buffer modifications of BODY are recorded on 4571the buffer's undo list as a single (apply ...) entry containing 4572the function `undo--wrap-and-run-primitive-undo'." 4573 (if (markerp beg) (setq beg (marker-position beg))) 4574 (if (markerp end) (setq end (marker-position end))) 4575 (let ((old-bul buffer-undo-list) 4576 (end-marker (copy-marker end t)) 4577 result) 4578 (if undo--combining-change-calls 4579 (setq result (funcall body)) 4580 (let ((undo--combining-change-calls t)) 4581 (if (not inhibit-modification-hooks) 4582 (run-hook-with-args 'before-change-functions beg end)) 4583 (let (;; (inhibit-modification-hooks t) 4584 (before-change-functions 4585 ;; Ugly Hack: if the body uses syntax-ppss/syntax-propertize 4586 ;; (e.g. via a regexp-search or sexp-movement triggering 4587 ;; on-the-fly syntax-propertize), make sure that this gets 4588 ;; properly refreshed after subsequent changes. 4589 (if (memq #'syntax-ppss-flush-cache before-change-functions) 4590 '(syntax-ppss-flush-cache))) 4591 after-change-functions) 4592 (setq result (funcall body))) 4593 (when (not (eq buffer-undo-list t)) 4594 (let ((ap-elt 4595 (list 'apply 4596 (- end end-marker) 4597 beg 4598 (marker-position end-marker) 4599 #'undo--wrap-and-run-primitive-undo 4600 beg (marker-position end-marker) buffer-undo-list)) 4601 (ptr buffer-undo-list)) 4602 (if (not (eq buffer-undo-list old-bul)) 4603 (progn 4604 (while (and (not (eq (cdr ptr) old-bul)) 4605 ;; In case garbage collection has removed OLD-BUL. 4606 (cdr ptr) 4607 ;; Don't include a timestamp entry. 4608 (not (and (consp (cdr ptr)) 4609 (consp (cadr ptr)) 4610 (eq (caadr ptr) t) 4611 (setq old-bul (cdr ptr))))) 4612 (setq ptr (cdr ptr))) 4613 (unless (cdr ptr) 4614 (message "combine-change-calls: buffer-undo-list broken")) 4615 (setcdr ptr nil) 4616 (push ap-elt buffer-undo-list) 4617 (setcdr buffer-undo-list old-bul))))) 4618 (if (not inhibit-modification-hooks) 4619 (run-hook-with-args 'after-change-functions 4620 beg (marker-position end-marker) 4621 (- end beg))))) 4622 (set-marker end-marker nil) 4623 result)) 4624 4625(defmacro combine-change-calls (beg end &rest body) 4626 "Evaluate BODY, running the change hooks just once. 4627 4628BODY is a sequence of Lisp forms to evaluate. BEG and END bound 4629the region the change hooks will be run for. 4630 4631Firstly, `before-change-functions' is invoked for the region 4632\(BEG END), then the BODY forms are evaluated with 4633`before-change-functions' and `after-change-functions' bound to 4634nil, and finally `after-change-functions' is invoked on the 4635updated region. The change hooks are not run if 4636`inhibit-modification-hooks' is initially non-nil. 4637 4638The result of `combine-change-calls' is the value returned by the 4639last of the BODY forms to be evaluated. BODY may not make a 4640different buffer current, except temporarily. BODY may not 4641change the buffer outside the specified region. It must not 4642change `before-change-functions' or `after-change-functions'. 4643 4644Additionally, the buffer modifications of BODY are recorded on 4645the buffer's undo list as a single \(apply ...) entry containing 4646the function `undo--wrap-and-run-primitive-undo'." 4647 (declare (debug (form form def-body)) (indent 2)) 4648 `(combine-change-calls-1 ,beg ,end (lambda () ,@body))) 4649 4650(defun undo--wrap-and-run-primitive-undo (beg end list) 4651 "Call `primitive-undo' on the undo elements in LIST. 4652 4653This function is intended to be called purely by `undo' as the 4654function in an \(apply DELTA BEG END FUNNAME . ARGS) undo 4655element. It invokes `before-change-functions' and 4656`after-change-functions' once each for the entire region \(BEG 4657END) rather than once for each individual change. 4658 4659Additionally the fresh \"redo\" elements which are generated on 4660`buffer-undo-list' will themselves be \"enclosed\" in 4661`undo--wrap-and-run-primitive-undo'. 4662 4663Undo elements of this form are generated by the macro 4664`combine-change-calls'." 4665 (combine-change-calls beg end 4666 (while list 4667 (setq list (primitive-undo 1 list))))) 4668 4669;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4670 4671(defmacro with-case-table (table &rest body) 4672 "Execute the forms in BODY with TABLE as the current case table. 4673The value returned is the value of the last form in BODY." 4674 (declare (indent 1) (debug t)) 4675 (let ((old-case-table (make-symbol "table")) 4676 (old-buffer (make-symbol "buffer"))) 4677 `(let ((,old-case-table (current-case-table)) 4678 (,old-buffer (current-buffer))) 4679 (unwind-protect 4680 (progn (set-case-table ,table) 4681 ,@body) 4682 (with-current-buffer ,old-buffer 4683 (set-case-table ,old-case-table)))))) 4684 4685(defmacro with-file-modes (modes &rest body) 4686 "Execute BODY with default file permissions temporarily set to MODES. 4687MODES is as for `set-default-file-modes'." 4688 (declare (indent 1) (debug t)) 4689 (let ((umask (make-symbol "umask"))) 4690 `(let ((,umask (default-file-modes))) 4691 (unwind-protect 4692 (progn 4693 (set-default-file-modes ,modes) 4694 ,@body) 4695 (set-default-file-modes ,umask))))) 4696 4697(defmacro with-existing-directory (&rest body) 4698 "Execute BODY with `default-directory' bound to an existing directory. 4699If `default-directory' is already an existing directory, it's not changed." 4700 (declare (indent 0) (debug t)) 4701 `(let ((default-directory (seq-find (lambda (dir) 4702 (and dir 4703 (file-exists-p dir))) 4704 (list default-directory 4705 (expand-file-name "~/") 4706 temporary-file-directory 4707 (getenv "TMPDIR") 4708 "/tmp/") 4709 "/"))) 4710 ,@body)) 4711 4712;;; Matching and match data. 4713 4714;; We use save-match-data-internal as the local variable because 4715;; that works ok in practice (people should not use that variable elsewhere). 4716;; We used to use an uninterned symbol; the compiler handles that properly 4717;; now, but it generates slower code. 4718(defmacro save-match-data (&rest body) 4719 "Execute the BODY forms, restoring the global value of the match data. 4720The value returned is the value of the last form in BODY. 4721NOTE: The convention in Elisp is that any function, except for a few 4722exceptions like car/assoc/+/goto-char, can clobber the match data, 4723so `save-match-data' should normally be used to save *your* match data 4724rather than your caller's match data." 4725 ;; It is better not to use backquote here, 4726 ;; because that makes a bootstrapping problem 4727 ;; if you need to recompile all the Lisp files using interpreted code. 4728 (declare (indent 0) (debug t)) 4729 (list 'let 4730 '((save-match-data-internal (match-data))) 4731 (list 'unwind-protect 4732 (cons 'progn body) 4733 ;; It is safe to free (evaporate) markers immediately here, 4734 ;; as Lisp programs should not copy from save-match-data-internal. 4735 '(set-match-data save-match-data-internal 'evaporate)))) 4736 4737(defun match-string (num &optional string) 4738 "Return the string of text matched by the previous search or regexp operation. 4739NUM specifies the number of the parenthesized sub-expression in the last 4740regexp whose match to return. Zero means return the text matched by the 4741entire regexp or the whole string. 4742 4743The return value is nil if NUMth pair didn't match anything, or if there 4744were fewer than NUM sub-expressions in the regexp used in the search. 4745 4746STRING should be given if the last search was by `string-match' 4747on STRING. If STRING is nil, the current buffer should be the 4748same buffer as the one in which the search/match was performed. 4749 4750Note that many functions in Emacs modify the match data, so this 4751function should be called \"close\" to the function that did the 4752regexp search. In particular, saying (for instance) 4753`M-: (looking-at \"[0-9]\") RET' followed by `M-: (match-string 0) RET' 4754interactively is seldom meaningful, since the Emacs command loop 4755may modify the match data." 4756 (declare (side-effect-free t)) 4757 (if (match-beginning num) 4758 (if string 4759 (substring string (match-beginning num) (match-end num)) 4760 (buffer-substring (match-beginning num) (match-end num))))) 4761 4762(defun match-string-no-properties (num &optional string) 4763 "Return string of text matched by last search, without text properties. 4764NUM specifies which parenthesized expression in the last regexp. 4765 Value is nil if NUMth pair didn't match, or there were less than NUM pairs. 4766Zero means the entire text matched by the whole regexp or whole string. 4767STRING should be given if the last search was by `string-match' on STRING. 4768If STRING is nil, the current buffer should be the same buffer 4769the search/match was performed in." 4770 (declare (side-effect-free t)) 4771 (if (match-beginning num) 4772 (if string 4773 (substring-no-properties string (match-beginning num) 4774 (match-end num)) 4775 (buffer-substring-no-properties (match-beginning num) 4776 (match-end num))))) 4777 4778 4779(defun match-substitute-replacement (replacement 4780 &optional fixedcase literal string subexp) 4781 "Return REPLACEMENT as it will be inserted by `replace-match'. 4782In other words, all back-references in the form `\\&' and `\\N' 4783are substituted with actual strings matched by the last search. 4784Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same 4785meaning as for `replace-match'." 4786 (let ((match (match-string 0 string))) 4787 (save-match-data 4788 (match-data--translate (- (match-beginning 0))) 4789 (replace-match replacement fixedcase literal match subexp)))) 4790 4791 4792(defun looking-back (regexp &optional limit greedy) 4793 "Return non-nil if text before point matches regular expression REGEXP. 4794Like `looking-at' except matches before point, and is slower. 4795LIMIT if non-nil speeds up the search by specifying a minimum 4796starting position, to avoid checking matches that would start 4797before LIMIT. 4798 4799If GREEDY is non-nil, extend the match backwards as far as 4800possible, stopping when a single additional previous character 4801cannot be part of a match for REGEXP. When the match is 4802extended, its starting position is allowed to occur before 4803LIMIT. 4804 4805As a general recommendation, try to avoid using `looking-back' 4806wherever possible, since it is slow." 4807 (declare 4808 (advertised-calling-convention (regexp limit &optional greedy) "25.1")) 4809 (let ((start (point)) 4810 (pos 4811 (save-excursion 4812 (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t) 4813 (point))))) 4814 (if (and greedy pos) 4815 (save-restriction 4816 (narrow-to-region (point-min) start) 4817 (while (and (> pos (point-min)) 4818 (save-excursion 4819 (goto-char pos) 4820 (backward-char 1) 4821 (looking-at (concat "\\(?:" regexp "\\)\\'")))) 4822 (setq pos (1- pos))) 4823 (save-excursion 4824 (goto-char pos) 4825 (looking-at (concat "\\(?:" regexp "\\)\\'"))))) 4826 (not (null pos)))) 4827 4828(defsubst looking-at-p (regexp) 4829 "\ 4830Same as `looking-at' except this function does not change the match data." 4831 (looking-at regexp t)) 4832 4833(defsubst string-match-p (regexp string &optional start) 4834 "\ 4835Same as `string-match' except this function does not change the match data." 4836 (string-match regexp string start t)) 4837 4838(defun subregexp-context-p (regexp pos &optional start) 4839 "Return non-nil if POS is in a normal subregexp context in REGEXP. 4840A subregexp context is one where a sub-regexp can appear. 4841A non-subregexp context is for example within brackets, or within a 4842repetition bounds operator `\\=\\{...\\}', or right after a `\\'. 4843If START is non-nil, it should be a position in REGEXP, smaller 4844than POS, and known to be in a subregexp context." 4845 ;; Here's one possible implementation, with the great benefit that it 4846 ;; reuses the regexp-matcher's own parser, so it understands all the 4847 ;; details of the syntax. A disadvantage is that it needs to match the 4848 ;; error string. 4849 (condition-case err 4850 (progn 4851 (string-match (substring regexp (or start 0) pos) "") 4852 t) 4853 (invalid-regexp 4854 (not (member (cadr err) '("Unmatched [ or [^" 4855 "Unmatched \\{" 4856 "Trailing backslash"))))) 4857 ;; An alternative implementation: 4858 ;; (defconst re-context-re 4859 ;; (let* ((harmless-ch "[^\\[]") 4860 ;; (harmless-esc "\\\\[^{]") 4861 ;; (class-harmless-ch "[^][]") 4862 ;; (class-lb-harmless "[^]:]") 4863 ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?") 4864 ;; (class-lb (concat "\\[\\(" class-lb-harmless 4865 ;; "\\|" class-lb-colon-maybe-charclass "\\)")) 4866 ;; (class 4867 ;; (concat "\\[^?]?" 4868 ;; "\\(" class-harmless-ch 4869 ;; "\\|" class-lb "\\)*" 4870 ;; "\\[?]")) ; special handling for bare [ at end of re 4871 ;; (braces "\\\\{[0-9,]+\\\\}")) 4872 ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc 4873 ;; "\\|" class "\\|" braces "\\)*\\'")) 4874 ;; "Matches any prefix that corresponds to a normal subregexp context.") 4875 ;; (string-match re-context-re (substring regexp (or start 0) pos)) 4876 ) 4877 4878;;;; split-string 4879 4880(defconst split-string-default-separators "[ \f\t\n\r\v]+" 4881 "The default value of separators for `split-string'. 4882 4883A regexp matching strings of whitespace. May be locale-dependent 4884\(as yet unimplemented). Should not match non-breaking spaces. 4885 4886Warning: binding this to a different value and using it as default is 4887likely to have undesired semantics.") 4888 4889;; The specification says that if both SEPARATORS and OMIT-NULLS are 4890;; defaulted, OMIT-NULLS should be treated as t. Simplifying the logical 4891;; expression leads to the equivalent implementation that if SEPARATORS 4892;; is defaulted, OMIT-NULLS is treated as t. 4893(defun split-string (string &optional separators omit-nulls trim) 4894 "Split STRING into substrings bounded by matches for SEPARATORS. 4895 4896The beginning and end of STRING, and each match for SEPARATORS, are 4897splitting points. The substrings matching SEPARATORS are removed, and 4898the substrings between the splitting points are collected as a list, 4899which is returned. 4900 4901If SEPARATORS is non-nil, it should be a regular expression matching text 4902that separates, but is not part of, the substrings. If nil it defaults to 4903`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and 4904OMIT-NULLS is forced to t. 4905 4906If OMIT-NULLS is t, zero-length substrings are omitted from the list (so 4907that for the default value of SEPARATORS leading and trailing whitespace 4908are effectively trimmed). If nil, all zero-length substrings are retained, 4909which correctly parses CSV format, for example. 4910 4911If TRIM is non-nil, it should be a regular expression to match 4912text to trim from the beginning and end of each substring. If trimming 4913makes the substring empty, it is treated as null. 4914 4915If you want to trim whitespace from the substrings, the reliably correct 4916way is using TRIM. Making SEPARATORS match that whitespace gives incorrect 4917results when there is whitespace at the start or end of STRING. If you 4918see such calls to `split-string', please fix them. 4919 4920Note that the effect of `(split-string STRING)' is the same as 4921`(split-string STRING split-string-default-separators t)'. In the rare 4922case that you wish to retain zero-length substrings when splitting on 4923whitespace, use `(split-string STRING split-string-default-separators)'. 4924 4925Modifies the match data; use `save-match-data' if necessary." 4926 (let* ((keep-nulls (not (if separators omit-nulls t))) 4927 (rexp (or separators split-string-default-separators)) 4928 (start 0) 4929 this-start this-end 4930 notfirst 4931 (list nil) 4932 (push-one 4933 ;; Push the substring in range THIS-START to THIS-END 4934 ;; onto LIST, trimming it and perhaps discarding it. 4935 (lambda () 4936 (when trim 4937 ;; Discard the trim from start of this substring. 4938 (let ((tem (string-match trim string this-start))) 4939 (and (eq tem this-start) 4940 (setq this-start (match-end 0))))) 4941 4942 (when (or keep-nulls (< this-start this-end)) 4943 (let ((this (substring string this-start this-end))) 4944 4945 ;; Discard the trim from end of this substring. 4946 (when trim 4947 (let ((tem (string-match (concat trim "\\'") this 0))) 4948 (and tem (< tem (length this)) 4949 (setq this (substring this 0 tem))))) 4950 4951 ;; Trimming could make it empty; check again. 4952 (when (or keep-nulls (> (length this) 0)) 4953 (push this list))))))) 4954 4955 (while (and (string-match rexp string 4956 (if (and notfirst 4957 (= start (match-beginning 0)) 4958 (< start (length string))) 4959 (1+ start) start)) 4960 (< start (length string))) 4961 (setq notfirst t) 4962 (setq this-start start this-end (match-beginning 0) 4963 start (match-end 0)) 4964 4965 (funcall push-one)) 4966 4967 ;; Handle the substring at the end of STRING. 4968 (setq this-start start this-end (length string)) 4969 (funcall push-one) 4970 4971 (nreverse list))) 4972 4973(defun combine-and-quote-strings (strings &optional separator) 4974 "Concatenate the STRINGS, adding the SEPARATOR (default \" \"). 4975This tries to quote the strings to avoid ambiguity such that 4976 (split-string-and-unquote (combine-and-quote-strings strs)) == strs 4977Only some SEPARATORs will work properly. 4978 4979Note that this is not intended to protect STRINGS from 4980interpretation by shells, use `shell-quote-argument' for that." 4981 (let* ((sep (or separator " ")) 4982 (re (concat "[\\\"]" "\\|" (regexp-quote sep)))) 4983 (mapconcat 4984 (lambda (str) 4985 (if (string-match re str) 4986 (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"") 4987 str)) 4988 strings sep))) 4989 4990(defun split-string-and-unquote (string &optional separator) 4991 "Split the STRING into a list of strings. 4992It understands Emacs Lisp quoting within STRING, such that 4993 (split-string-and-unquote (combine-and-quote-strings strs)) == strs 4994The SEPARATOR regexp defaults to \"\\s-+\"." 4995 (let ((sep (or separator "\\s-+")) 4996 (i (string-search "\"" string))) 4997 (if (null i) 4998 (split-string string sep t) ; no quoting: easy 4999 (append (unless (eq i 0) (split-string (substring string 0 i) sep t)) 5000 (let ((rfs (read-from-string string i))) 5001 (cons (car rfs) 5002 (split-string-and-unquote (substring string (cdr rfs)) 5003 sep))))))) 5004 5005 5006;;;; Replacement in strings. 5007 5008(defun subst-char-in-string (fromchar tochar string &optional inplace) 5009 "Replace FROMCHAR with TOCHAR in STRING each time it occurs. 5010Unless optional argument INPLACE is non-nil, return a new string." 5011 (let ((i (length string)) 5012 (newstr (if inplace string (copy-sequence string)))) 5013 (while (> i 0) 5014 (setq i (1- i)) 5015 (if (eq (aref newstr i) fromchar) 5016 (aset newstr i tochar))) 5017 newstr)) 5018 5019(defun string-replace (from-string to-string in-string) 5020 "Replace FROM-STRING with TO-STRING in IN-STRING each time it occurs." 5021 (declare (pure t) (side-effect-free t)) 5022 (when (equal from-string "") 5023 (signal 'wrong-length-argument '(0))) 5024 (let ((start 0) 5025 (result nil) 5026 pos) 5027 (while (setq pos (string-search from-string in-string start)) 5028 (unless (= start pos) 5029 (push (substring in-string start pos) result)) 5030 (push to-string result) 5031 (setq start (+ pos (length from-string)))) 5032 (if (null result) 5033 ;; No replacements were done, so just return the original string. 5034 in-string 5035 ;; Get any remaining bit. 5036 (unless (= start (length in-string)) 5037 (push (substring in-string start) result)) 5038 (apply #'concat (nreverse result))))) 5039 5040(defun replace-regexp-in-string (regexp rep string &optional 5041 fixedcase literal subexp start) 5042 "Replace all matches for REGEXP with REP in STRING. 5043 5044Return a new string containing the replacements. 5045 5046Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the 5047arguments with the same names of function `replace-match'. If START 5048is non-nil, start replacements at that index in STRING, and omit 5049the first START characters of STRING from the return value. 5050 5051REP is either a string used as the NEWTEXT arg of `replace-match' or a 5052function. If it is a function, it is called with the actual text of each 5053match, and its value is used as the replacement text. When REP is called, 5054the match data are the result of matching REGEXP against a substring 5055of STRING, the same substring that is the actual text of the match which 5056is passed to REP as its argument. 5057 5058To replace only the first match (if any), make REGEXP match up to \\\\=' 5059and replace a sub-expression, e.g. 5060 (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\\\='\" \"bar\" \" foo foo\" nil nil 1) 5061 => \" bar foo\"" 5062 5063 ;; To avoid excessive consing from multiple matches in long strings, 5064 ;; don't just call `replace-match' continually. Walk down the 5065 ;; string looking for matches of REGEXP and building up a (reversed) 5066 ;; list MATCHES. This comprises segments of STRING that weren't 5067 ;; matched interspersed with replacements for segments that were. 5068 ;; [For a `large' number of replacements it's more efficient to 5069 ;; operate in a temporary buffer; we can't tell from the function's 5070 ;; args whether to choose the buffer-based implementation, though it 5071 ;; might be reasonable to do so for long enough STRING.] 5072 (let ((l (length string)) 5073 (start (or start 0)) 5074 matches str mb me) 5075 (save-match-data 5076 (while (and (< start l) (string-match regexp string start)) 5077 (setq mb (match-beginning 0) 5078 me (match-end 0)) 5079 ;; If we matched the empty string, make sure we advance by one char 5080 (when (= me mb) (setq me (min l (1+ mb)))) 5081 ;; Generate a replacement for the matched substring. 5082 ;; Operate on only the substring to minimize string consing. 5083 ;; Translate the match data so that it applies to the matched substring. 5084 (match-data--translate (- mb)) 5085 (setq str (substring string mb me)) 5086 (setq matches 5087 (cons (replace-match (if (stringp rep) 5088 rep 5089 (funcall rep (match-string 0 str))) 5090 fixedcase literal str subexp) 5091 (cons (substring string start mb) ; unmatched prefix 5092 matches))) 5093 (setq start me)) 5094 ;; Reconstruct a string from the pieces. 5095 (setq matches (cons (substring string start l) matches)) ; leftover 5096 (apply #'concat (nreverse matches))))) 5097 5098(defun string-prefix-p (prefix string &optional ignore-case) 5099 "Return non-nil if PREFIX is a prefix of STRING. 5100If IGNORE-CASE is non-nil, the comparison is done without paying attention 5101to case differences." 5102 (let ((prefix-length (length prefix))) 5103 (if (> prefix-length (length string)) nil 5104 (eq t (compare-strings prefix 0 prefix-length string 5105 0 prefix-length ignore-case))))) 5106 5107(defun string-suffix-p (suffix string &optional ignore-case) 5108 "Return non-nil if SUFFIX is a suffix of STRING. 5109If IGNORE-CASE is non-nil, the comparison is done without paying 5110attention to case differences." 5111 (let ((start-pos (- (length string) (length suffix)))) 5112 (and (>= start-pos 0) 5113 (eq t (compare-strings suffix nil nil 5114 string start-pos nil ignore-case))))) 5115 5116(defun bidi-string-mark-left-to-right (str) 5117 "Return a string that can be safely inserted in left-to-right text. 5118 5119Normally, inserting a string with right-to-left (RTL) script into 5120a buffer may cause some subsequent text to be displayed as part 5121of the RTL segment (usually this affects punctuation characters). 5122This function returns a string that displays as STR but forces 5123subsequent text to be displayed as left-to-right. 5124 5125If STR contains any RTL character, this function returns a string 5126consisting of STR followed by an invisible left-to-right mark 5127\(LRM) character. Otherwise, it returns STR." 5128 (unless (stringp str) 5129 (signal 'wrong-type-argument (list 'stringp str))) 5130 (if (string-match "\\cR" str) 5131 (concat str (propertize (string ?\x200e) 'invisible t)) 5132 str)) 5133 5134(defun string-greaterp (string1 string2) 5135 "Return non-nil if STRING1 is greater than STRING2 in lexicographic order. 5136Case is significant. 5137Symbols are also allowed; their print names are used instead." 5138 (string-lessp string2 string1)) 5139 5140 5141;;;; Specifying things to do later. 5142 5143(defun load-history-regexp (file) 5144 "Form a regexp to find FILE in `load-history'. 5145FILE, a string, is described in the function `eval-after-load'." 5146 (if (file-name-absolute-p file) 5147 (setq file (file-truename file))) 5148 (concat (if (file-name-absolute-p file) "\\`" "\\(\\`\\|/\\)") 5149 (regexp-quote file) 5150 (if (file-name-extension file) 5151 "" 5152 ;; Note: regexp-opt can't be used here, since we need to call 5153 ;; this before Emacs has been fully started. 2006-05-21 5154 (concat "\\(" (mapconcat #'regexp-quote load-suffixes "\\|") "\\)?")) 5155 "\\(" (mapconcat #'regexp-quote jka-compr-load-suffixes "\\|") 5156 "\\)?\\'")) 5157 5158(defun load-history-filename-element (file-regexp) 5159 "Get the first elt of `load-history' whose car matches FILE-REGEXP. 5160Return nil if there isn't one." 5161 (let* ((loads load-history) 5162 (load-elt (and loads (car loads)))) 5163 (save-match-data 5164 (while (and loads 5165 (or (null (car load-elt)) 5166 (not (string-match file-regexp (car load-elt))))) 5167 (setq loads (cdr loads) 5168 load-elt (and loads (car loads))))) 5169 load-elt)) 5170 5171(defun eval-after-load (file form) 5172 "Arrange that if FILE is loaded, FORM will be run immediately afterwards. 5173If FILE is already loaded, evaluate FORM right now. 5174FORM can be an Elisp expression (in which case it's passed to `eval'), 5175or a function (in which case it's passed to `funcall' with no argument). 5176 5177If a matching file is loaded again, FORM will be evaluated again. 5178 5179If FILE is a string, it may be either an absolute or a relative file 5180name, and may have an extension (e.g. \".el\") or may lack one, and 5181additionally may or may not have an extension denoting a compressed 5182format (e.g. \".gz\"). 5183 5184When FILE is absolute, this first converts it to a true name by chasing 5185symbolic links. Only a file of this name (see next paragraph regarding 5186extensions) will trigger the evaluation of FORM. When FILE is relative, 5187a file whose absolute true name ends in FILE will trigger evaluation. 5188 5189When FILE lacks an extension, a file name with any extension will trigger 5190evaluation. Otherwise, its extension must match FILE's. A further 5191extension for a compressed format (e.g. \".gz\") on FILE will not affect 5192this name matching. 5193 5194Alternatively, FILE can be a feature (i.e. a symbol), in which case FORM 5195is evaluated at the end of any file that `provide's this feature. 5196If the feature is provided when evaluating code not associated with a 5197file, FORM is evaluated immediately after the provide statement. 5198 5199Usually FILE is just a library name like \"font-lock\" or a feature name 5200like `font-lock'. 5201 5202This function makes or adds to an entry on `after-load-alist'. 5203 5204See also `with-eval-after-load'." 5205 (declare (indent 1) 5206 (compiler-macro 5207 (lambda (whole) 5208 (if (eq 'quote (car-safe form)) 5209 ;; Quote with lambda so the compiler can look inside. 5210 `(eval-after-load ,file (lambda () ,(nth 1 form))) 5211 whole)))) 5212 ;; Add this FORM into after-load-alist (regardless of whether we'll be 5213 ;; evaluating it now). 5214 (let* ((regexp-or-feature 5215 (if (stringp file) 5216 (setq file (purecopy (load-history-regexp file))) 5217 file)) 5218 (elt (assoc regexp-or-feature after-load-alist)) 5219 (func 5220 (if (functionp form) form 5221 ;; Try to use the "current" lexical/dynamic mode for `form'. 5222 (eval `(lambda () ,form) lexical-binding)))) 5223 (unless elt 5224 (setq elt (list regexp-or-feature)) 5225 (push elt after-load-alist)) 5226 ;; Is there an already loaded file whose name (or `provide' name) 5227 ;; matches FILE? 5228 (prog1 (if (if (stringp file) 5229 (load-history-filename-element regexp-or-feature) 5230 (featurep file)) 5231 (funcall func)) 5232 (let ((delayed-func 5233 (if (not (symbolp regexp-or-feature)) func 5234 ;; For features, the after-load-alist elements get run when 5235 ;; `provide' is called rather than at the end of the file. 5236 ;; So add an indirection to make sure that `func' is really run 5237 ;; "after-load" in case the provide call happens early. 5238 (lambda () 5239 (if (not load-file-name) 5240 ;; Not being provided from a file, run func right now. 5241 (funcall func) 5242 (let ((lfn load-file-name) 5243 ;; Don't use letrec, because equal (in 5244 ;; add/remove-hook) could get trapped in a cycle 5245 ;; (bug#46326). 5246 (fun (make-symbol "eval-after-load-helper"))) 5247 (fset fun (lambda (file) 5248 (when (equal file lfn) 5249 (remove-hook 'after-load-functions fun) 5250 (funcall func)))) 5251 (add-hook 'after-load-functions fun 'append))))))) 5252 ;; Add FORM to the element unless it's already there. 5253 (unless (member delayed-func (cdr elt)) 5254 (nconc elt (list delayed-func))))))) 5255 5256(defmacro with-eval-after-load (file &rest body) 5257 "Execute BODY after FILE is loaded. 5258FILE is normally a feature name, but it can also be a file name, 5259in case that file does not provide any feature. See `eval-after-load' 5260for more details about the different forms of FILE and their semantics." 5261 (declare (indent 1) (debug (form def-body))) 5262 `(eval-after-load ,file (lambda () ,@body))) 5263 5264(defvar after-load-functions nil 5265 "Special hook run after loading a file. 5266Each function there is called with a single argument, the absolute 5267name of the file just loaded.") 5268 5269(defun do-after-load-evaluation (abs-file) 5270 "Evaluate all `eval-after-load' forms, if any, for ABS-FILE. 5271ABS-FILE, a string, should be the absolute true name of a file just loaded. 5272This function is called directly from the C code." 5273 ;; Run the relevant eval-after-load forms. 5274 (dolist (a-l-element after-load-alist) 5275 (when (and (stringp (car a-l-element)) 5276 (string-match-p (car a-l-element) abs-file)) 5277 ;; discard the file name regexp 5278 (mapc #'funcall (cdr a-l-element)))) 5279 ;; Complain when the user uses obsolete files. 5280 (when (string-match-p "/obsolete/[^/]*\\'" abs-file) 5281 ;; Maybe we should just use display-warning? This seems yucky... 5282 (let* ((file (file-name-nondirectory abs-file)) 5283 (package (intern (substring file 0 5284 (string-match "\\.elc?\\>" file)) 5285 obarray)) 5286 (msg (format "Package %s is deprecated" package)) 5287 (fun (lambda (msg) (message "%s" msg)))) 5288 (when (or (not (fboundp 'byte-compile-warning-enabled-p)) 5289 (byte-compile-warning-enabled-p 'obsolete package)) 5290 (cond 5291 ((bound-and-true-p byte-compile-current-file) 5292 ;; Don't warn about obsolete files using other obsolete files. 5293 (unless (and (stringp byte-compile-current-file) 5294 (string-match-p "/obsolete/[^/]*\\'" 5295 (expand-file-name 5296 byte-compile-current-file 5297 byte-compile-root-dir))) 5298 (byte-compile-warn "%s" msg))) 5299 (noninteractive (funcall fun msg)) ;; No timer will be run! 5300 (t (run-with-idle-timer 0 nil fun msg)))))) 5301 5302 ;; Finally, run any other hook. 5303 (run-hook-with-args 'after-load-functions abs-file)) 5304 5305 5306(defun display-delayed-warnings () 5307 "Display delayed warnings from `delayed-warnings-list'. 5308Used from `delayed-warnings-hook' (which see)." 5309 (dolist (warning (nreverse delayed-warnings-list)) 5310 (apply #'display-warning warning)) 5311 (setq delayed-warnings-list nil)) 5312 5313(defun collapse-delayed-warnings () 5314 "Remove duplicates from `delayed-warnings-list'. 5315Collapse identical adjacent warnings into one (plus count). 5316Used from `delayed-warnings-hook' (which see)." 5317 (let ((count 1) 5318 collapsed warning) 5319 (while delayed-warnings-list 5320 (setq warning (pop delayed-warnings-list)) 5321 (if (equal warning (car delayed-warnings-list)) 5322 (setq count (1+ count)) 5323 (when (> count 1) 5324 (setcdr warning (cons (format "%s [%d times]" (cadr warning) count) 5325 (cddr warning))) 5326 (setq count 1)) 5327 (push warning collapsed))) 5328 (setq delayed-warnings-list (nreverse collapsed)))) 5329 5330;; At present this is used only for Emacs internals. 5331;; Ref https://lists.gnu.org/r/emacs-devel/2012-02/msg00085.html 5332(defvar delayed-warnings-hook '(collapse-delayed-warnings 5333 display-delayed-warnings) 5334 "Normal hook run to process and display delayed warnings. 5335By default, this hook contains functions to consolidate the 5336warnings listed in `delayed-warnings-list', display them, and set 5337`delayed-warnings-list' back to nil.") 5338 5339(defun delay-warning (type message &optional level buffer-name) 5340 "Display a delayed warning. 5341Aside from going through `delayed-warnings-list', this is equivalent 5342to `display-warning'." 5343 (push (list type message level buffer-name) delayed-warnings-list)) 5344 5345 5346;;;; invisibility specs 5347 5348(defun add-to-invisibility-spec (element) 5349 "Add ELEMENT to `buffer-invisibility-spec'. 5350See documentation for `buffer-invisibility-spec' for the kind of elements 5351that can be added. 5352 5353If `buffer-invisibility-spec' isn't a list before calling this 5354function, `buffer-invisibility-spec' will afterwards be a list 5355with the value `(t ELEMENT)'. This means that if text exists 5356that invisibility values that aren't either t or ELEMENT, that 5357text will become visible." 5358 (if (eq buffer-invisibility-spec t) 5359 (setq buffer-invisibility-spec (list t))) 5360 (setq buffer-invisibility-spec 5361 (cons element buffer-invisibility-spec))) 5362 5363(defun remove-from-invisibility-spec (element) 5364 "Remove ELEMENT from `buffer-invisibility-spec'. 5365If `buffer-invisibility-spec' isn't a list before calling this 5366function, it will be made into a list containing just t as the 5367only list member. This means that if text exists with non-t 5368invisibility values, that text will become visible." 5369 (setq buffer-invisibility-spec 5370 (if (consp buffer-invisibility-spec) 5371 (delete element buffer-invisibility-spec) 5372 (list t)))) 5373 5374;;;; Syntax tables. 5375 5376(defmacro with-syntax-table (table &rest body) 5377 "Evaluate BODY with syntax table of current buffer set to TABLE. 5378The syntax table of the current buffer is saved, BODY is evaluated, and the 5379saved table is restored, even in case of an abnormal exit. 5380Value is what BODY returns." 5381 (declare (debug t) (indent 1)) 5382 (let ((old-table (make-symbol "table")) 5383 (old-buffer (make-symbol "buffer"))) 5384 `(let ((,old-table (syntax-table)) 5385 (,old-buffer (current-buffer))) 5386 (unwind-protect 5387 (progn 5388 (set-syntax-table ,table) 5389 ,@body) 5390 (save-current-buffer 5391 (set-buffer ,old-buffer) 5392 (set-syntax-table ,old-table)))))) 5393 5394(defun make-syntax-table (&optional oldtable) 5395 "Return a new syntax table. 5396Create a syntax table that inherits from OLDTABLE (if non-nil) or 5397from `standard-syntax-table' otherwise." 5398 (let ((table (make-char-table 'syntax-table nil))) 5399 (set-char-table-parent table (or oldtable (standard-syntax-table))) 5400 table)) 5401 5402(defun syntax-after (pos) 5403 "Return the raw syntax descriptor for the char after POS. 5404If POS is outside the buffer's accessible portion, return nil." 5405 (unless (or (< pos (point-min)) (>= pos (point-max))) 5406 (let ((st (if parse-sexp-lookup-properties 5407 (get-char-property pos 'syntax-table)))) 5408 (if (consp st) st 5409 (aref (or st (syntax-table)) (char-after pos)))))) 5410 5411(defun syntax-class (syntax) 5412 "Return the code for the syntax class described by SYNTAX. 5413 5414SYNTAX should be a raw syntax descriptor; the return value is a 5415integer that encodes the corresponding syntax class. See Info 5416node `(elisp)Syntax Table Internals' for a list of codes. 5417 5418If SYNTAX is nil, return nil." 5419 (and syntax (logand (car syntax) 65535))) 5420 5421;; Utility motion commands 5422 5423(defvar word-move-empty-char-table nil 5424 "Used in `forward-word-strictly' and `backward-word-strictly' 5425to countermand the effect of `find-word-boundary-function-table'.") 5426 5427(defun forward-word-strictly (&optional arg) 5428 "Move point forward ARG words (backward if ARG is negative). 5429If ARG is omitted or nil, move point forward one word. 5430Normally returns t. 5431If an edge of the buffer or a field boundary is reached, point is left there 5432and the function returns nil. Field boundaries are not noticed if 5433`inhibit-field-text-motion' is non-nil. 5434 5435This function is like `forward-word', but it is not affected 5436by `find-word-boundary-function-table'. It is also not interactive." 5437 (let ((find-word-boundary-function-table 5438 (if (char-table-p word-move-empty-char-table) 5439 word-move-empty-char-table 5440 (setq word-move-empty-char-table (make-char-table nil))))) 5441 (forward-word (or arg 1)))) 5442 5443(defun backward-word-strictly (&optional arg) 5444 "Move backward until encountering the beginning of a word. 5445With argument ARG, do this that many times. 5446If ARG is omitted or nil, move point backward one word. 5447 5448This function is like `forward-word', but it is not affected 5449by `find-word-boundary-function-table'. It is also not interactive." 5450 (let ((find-word-boundary-function-table 5451 (if (char-table-p word-move-empty-char-table) 5452 word-move-empty-char-table 5453 (setq word-move-empty-char-table (make-char-table nil))))) 5454 (forward-word (- (or arg 1))))) 5455 5456;; Whitespace 5457 5458(defun forward-whitespace (arg) 5459 "Move point to the end of the next sequence of whitespace chars. 5460Each such sequence may be a single newline, or a sequence of 5461consecutive space and/or tab characters. 5462With prefix argument ARG, do it ARG times if positive, or move 5463backwards ARG times if negative." 5464 (interactive "^p") 5465 (if (natnump arg) 5466 (re-search-forward "[ \t]+\\|\n" nil 'move arg) 5467 (while (< arg 0) 5468 (if (re-search-backward "[ \t]+\\|\n" nil 'move) 5469 (or (eq (char-after (match-beginning 0)) ?\n) 5470 (skip-chars-backward " \t"))) 5471 (setq arg (1+ arg))))) 5472 5473;; Symbols 5474 5475(defun forward-symbol (arg) 5476 "Move point to the next position that is the end of a symbol. 5477A symbol is any sequence of characters that are in either the 5478word constituent or symbol constituent syntax class. 5479With prefix argument ARG, do it ARG times if positive, or move 5480backwards ARG times if negative." 5481 (interactive "^p") 5482 (if (natnump arg) 5483 (re-search-forward "\\(\\sw\\|\\s_\\)+" nil 'move arg) 5484 (while (< arg 0) 5485 (if (re-search-backward "\\(\\sw\\|\\s_\\)+" nil 'move) 5486 (skip-syntax-backward "w_")) 5487 (setq arg (1+ arg))))) 5488 5489;; Syntax blocks 5490 5491(defun forward-same-syntax (&optional arg) 5492 "Move point past all characters with the same syntax class. 5493With prefix argument ARG, do it ARG times if positive, or move 5494backwards ARG times if negative." 5495 (interactive "^p") 5496 (or arg (setq arg 1)) 5497 (while (< arg 0) 5498 (skip-syntax-backward 5499 (char-to-string (char-syntax (char-before)))) 5500 (setq arg (1+ arg))) 5501 (while (> arg 0) 5502 (skip-syntax-forward (char-to-string (char-syntax (char-after)))) 5503 (setq arg (1- arg)))) 5504 5505 5506;;;; Text clones 5507 5508(defvar text-clone--maintaining nil) 5509 5510(defun text-clone--maintain (ol1 after beg end &optional _len) 5511 "Propagate the changes made under the overlay OL1 to the other clones. 5512This is used on the `modification-hooks' property of text clones." 5513 (when (and after (not undo-in-progress) 5514 (not text-clone--maintaining) 5515 (overlay-start ol1)) 5516 (let ((margin (if (overlay-get ol1 'text-clone-spreadp) 1 0))) 5517 (setq beg (max beg (+ (overlay-start ol1) margin))) 5518 (setq end (min end (- (overlay-end ol1) margin))) 5519 (when (<= beg end) 5520 (save-excursion 5521 (when (overlay-get ol1 'text-clone-syntax) 5522 ;; Check content of the clone's text. 5523 (let ((cbeg (+ (overlay-start ol1) margin)) 5524 (cend (- (overlay-end ol1) margin))) 5525 (goto-char cbeg) 5526 (save-match-data 5527 (if (not (re-search-forward 5528 (overlay-get ol1 'text-clone-syntax) cend t)) 5529 ;; Mark the overlay for deletion. 5530 (setq end cbeg) 5531 (when (< (match-end 0) cend) 5532 ;; Shrink the clone at its end. 5533 (setq end (min end (match-end 0))) 5534 (move-overlay ol1 (overlay-start ol1) 5535 (+ (match-end 0) margin))) 5536 (when (> (match-beginning 0) cbeg) 5537 ;; Shrink the clone at its beginning. 5538 (setq beg (max (match-beginning 0) beg)) 5539 (move-overlay ol1 (- (match-beginning 0) margin) 5540 (overlay-end ol1))))))) 5541 ;; Now go ahead and update the clones. 5542 (let ((head (- beg (overlay-start ol1))) 5543 (tail (- (overlay-end ol1) end)) 5544 (str (buffer-substring beg end)) 5545 (nothing-left t) 5546 (text-clone--maintaining t)) 5547 (dolist (ol2 (overlay-get ol1 'text-clones)) 5548 (let ((oe (overlay-end ol2))) 5549 (unless (or (eq ol1 ol2) (null oe)) 5550 (setq nothing-left nil) 5551 (let ((mod-beg (+ (overlay-start ol2) head))) 5552 ;;(overlay-put ol2 'modification-hooks nil) 5553 (goto-char (- (overlay-end ol2) tail)) 5554 (unless (> mod-beg (point)) 5555 (save-excursion (insert str)) 5556 (delete-region mod-beg (point))) 5557 ;;(overlay-put ol2 'modification-hooks '(text-clone--maintain)) 5558 )))) 5559 (if nothing-left (delete-overlay ol1)))))))) 5560 5561(defun text-clone-create (start end &optional spreadp syntax) 5562 "Create a text clone of START...END at point. 5563Text clones are chunks of text that are automatically kept identical: 5564changes done to one of the clones will be immediately propagated to the other. 5565 5566The buffer's content at point is assumed to be already identical to 5567the one between START and END. 5568If SYNTAX is provided it's a regexp that describes the possible text of 5569the clones; the clone will be shrunk or killed if necessary to ensure that 5570its text matches the regexp. 5571If SPREADP is non-nil it indicates that text inserted before/after the 5572clone should be incorporated in the clone." 5573 ;; To deal with SPREADP we can either use an overlay with `nil t' along 5574 ;; with insert-(behind|in-front-of)-hooks or use a slightly larger overlay 5575 ;; (with a one-char margin at each end) with `t nil'. 5576 ;; We opted for a larger overlay because it behaves better in the case 5577 ;; where the clone is reduced to the empty string (we want the overlay to 5578 ;; stay when the clone's content is the empty string and we want to use 5579 ;; `evaporate' to make sure those overlays get deleted when needed). 5580 ;; 5581 (let* ((pt-end (+ (point) (- end start))) 5582 (start-margin (if (or (not spreadp) (bobp) (<= start (point-min))) 5583 0 1)) 5584 (end-margin (if (or (not spreadp) 5585 (>= pt-end (point-max)) 5586 (>= start (point-max))) 5587 0 1)) 5588 ;; FIXME: Reuse overlays at point to extend dups! 5589 (ol1 (make-overlay (- start start-margin) (+ end end-margin) nil t)) 5590 (ol2 (make-overlay (- (point) start-margin) (+ pt-end end-margin) nil t)) 5591 (dups (list ol1 ol2))) 5592 (overlay-put ol1 'modification-hooks '(text-clone--maintain)) 5593 (when spreadp (overlay-put ol1 'text-clone-spreadp t)) 5594 (when syntax (overlay-put ol1 'text-clone-syntax syntax)) 5595 ;;(overlay-put ol1 'face 'underline) 5596 (overlay-put ol1 'evaporate t) 5597 (overlay-put ol1 'text-clones dups) 5598 ;; 5599 (overlay-put ol2 'modification-hooks '(text-clone--maintain)) 5600 (when spreadp (overlay-put ol2 'text-clone-spreadp t)) 5601 (when syntax (overlay-put ol2 'text-clone-syntax syntax)) 5602 ;;(overlay-put ol2 'face 'underline) 5603 (overlay-put ol2 'evaporate t) 5604 (overlay-put ol2 'text-clones dups))) 5605 5606;;;; Mail user agents. 5607 5608;; Here we include just enough for other packages to be able 5609;; to define them. 5610 5611(defun define-mail-user-agent (symbol composefunc sendfunc 5612 &optional abortfunc hookvar) 5613 "Define a symbol to identify a mail-sending package for `mail-user-agent'. 5614 5615SYMBOL can be any Lisp symbol. Its function definition and/or 5616value as a variable do not matter for this usage; we use only certain 5617properties on its property list, to encode the rest of the arguments. 5618 5619COMPOSEFUNC is program callable function that composes an outgoing 5620mail message buffer. This function should set up the basics of the 5621buffer without requiring user interaction. It should populate the 5622standard mail headers, leaving the `to:' and `subject:' headers blank 5623by default. 5624 5625COMPOSEFUNC should accept several optional arguments--the same 5626arguments that `compose-mail' takes. See that function's documentation. 5627 5628SENDFUNC is the command a user would run to send the message. 5629 5630Optional ABORTFUNC is the command a user would run to abort the 5631message. For mail packages that don't have a separate abort function, 5632this can be `kill-buffer' (the equivalent of omitting this argument). 5633 5634Optional HOOKVAR is a hook variable that gets run before the message 5635is actually sent. Callers that use the `mail-user-agent' may 5636install a hook function temporarily on this hook variable. 5637If HOOKVAR is nil, `mail-send-hook' is used. 5638 5639The properties used on SYMBOL are `composefunc', `sendfunc', 5640`abortfunc', and `hookvar'." 5641 (declare (indent defun)) 5642 (put symbol 'composefunc composefunc) 5643 (put symbol 'sendfunc sendfunc) 5644 (put symbol 'abortfunc (or abortfunc #'kill-buffer)) 5645 (put symbol 'hookvar (or hookvar 'mail-send-hook))) 5646 5647 5648(defun backtrace-frames (&optional base) 5649 "Collect all frames of current backtrace into a list. 5650If non-nil, BASE should be a function, and frames before its 5651nearest activation frame are discarded." 5652 (let ((frames nil)) 5653 (mapbacktrace (lambda (&rest frame) (push frame frames)) 5654 (or base 'backtrace-frames)) 5655 (nreverse frames))) 5656 5657(defun backtrace-frame (nframes &optional base) 5658 "Return the function and arguments NFRAMES up from current execution point. 5659If non-nil, BASE should be a function, and NFRAMES counts from its 5660nearest activation frame. 5661If the frame has not evaluated the arguments yet (or is a special form), 5662the value is (nil FUNCTION ARG-FORMS...). 5663If the frame has evaluated its arguments and called its function already, 5664the value is (t FUNCTION ARG-VALUES...). 5665A &rest arg is represented as the tail of the list ARG-VALUES. 5666FUNCTION is whatever was supplied as car of evaluated list, 5667or a lambda expression for macro calls. 5668If NFRAMES is more than the number of frames, the value is nil." 5669 (backtrace-frame--internal 5670 (lambda (evald func args _) `(,evald ,func ,@args)) 5671 nframes (or base 'backtrace-frame))) 5672 5673 5674(defvar called-interactively-p-functions nil 5675 "Special hook called to skip special frames in `called-interactively-p'. 5676The functions are called with 3 arguments: (I FRAME1 FRAME2), 5677where FRAME1 is a \"current frame\", FRAME2 is the next frame, 5678I is the index of the frame after FRAME2. It should return nil 5679if those frames don't seem special and otherwise, it should return 5680the number of frames to skip (minus 1).") 5681 5682(defconst internal--funcall-interactively 5683 (symbol-function 'funcall-interactively)) 5684 5685(defun called-interactively-p (&optional kind) 5686 "Return t if the containing function was called by `call-interactively'. 5687If KIND is `interactive', then return t only if the call was made 5688interactively by the user, i.e. not in `noninteractive' mode nor 5689when `executing-kbd-macro'. 5690If KIND is `any', on the other hand, it will return t for any kind of 5691interactive call, including being called as the binding of a key or 5692from a keyboard macro, even in `noninteractive' mode. 5693 5694This function is very brittle, it may fail to return the intended result when 5695the code is debugged, advised, or instrumented in some form. Some macros and 5696special forms (such as `condition-case') may also sometimes wrap their bodies 5697in a `lambda', so any call to `called-interactively-p' from those bodies will 5698indicate whether that lambda (rather than the surrounding function) was called 5699interactively. 5700 5701Instead of using this function, it is cleaner and more reliable to give your 5702function an extra optional argument whose `interactive' spec specifies 5703non-nil unconditionally (\"p\" is a good way to do this), or via 5704\(not (or executing-kbd-macro noninteractive)). 5705 5706The only known proper use of `interactive' for KIND is in deciding 5707whether to display a helpful message, or how to display it. If you're 5708thinking of using it for any other purpose, it is quite likely that 5709you're making a mistake. Think: what do you want to do when the 5710command is called from a keyboard macro?" 5711 (declare (advertised-calling-convention (kind) "23.1")) 5712 (when (not (and (eq kind 'interactive) 5713 (or executing-kbd-macro noninteractive))) 5714 (let* ((i 1) ;; 0 is the called-interactively-p frame. 5715 frame nextframe 5716 (get-next-frame 5717 (lambda () 5718 (setq frame nextframe) 5719 (setq nextframe (backtrace-frame i 'called-interactively-p)) 5720 ;; (message "Frame %d = %S" i nextframe) 5721 (setq i (1+ i))))) 5722 (funcall get-next-frame) ;; Get the first frame. 5723 (while 5724 ;; FIXME: The edebug and advice handling should be made modular and 5725 ;; provided directly by edebug.el and nadvice.el. 5726 (progn 5727 ;; frame =(backtrace-frame i-2) 5728 ;; nextframe=(backtrace-frame i-1) 5729 (funcall get-next-frame) 5730 ;; `pcase' would be a fairly good fit here, but it sometimes moves 5731 ;; branches within local functions, which then messes up the 5732 ;; `backtrace-frame' data we get, 5733 (or 5734 ;; Skip special forms (from non-compiled code). 5735 (and frame (null (car frame))) 5736 ;; Skip also `interactive-p' (because we don't want to know if 5737 ;; interactive-p was called interactively but if it's caller was) 5738 ;; and `byte-code' (idem; this appears in subexpressions of things 5739 ;; like condition-case, which are wrapped in a separate bytecode 5740 ;; chunk). 5741 ;; FIXME: For lexical-binding code, this is much worse, 5742 ;; because the frames look like "byte-code -> funcall -> #[...]", 5743 ;; which is not a reliable signature. 5744 (memq (nth 1 frame) '(interactive-p 'byte-code)) 5745 ;; Skip package-specific stack-frames. 5746 (let ((skip (run-hook-with-args-until-success 5747 'called-interactively-p-functions 5748 i frame nextframe))) 5749 (pcase skip 5750 ('nil nil) 5751 (0 t) 5752 (_ (setq i (+ i skip -1)) (funcall get-next-frame))))))) 5753 ;; Now `frame' should be "the function from which we were called". 5754 (pcase (cons frame nextframe) 5755 ;; No subr calls `interactive-p', so we can rule that out. 5756 (`((,_ ,(pred (lambda (f) (subr-primitive-p (indirect-function f)))) . ,_) . ,_) nil) 5757 ;; In case #<subr funcall-interactively> without going through the 5758 ;; `funcall-interactively' symbol (bug#3984). 5759 (`(,_ . (t ,(pred (lambda (f) 5760 (eq internal--funcall-interactively 5761 (indirect-function f)))) 5762 . ,_)) 5763 t))))) 5764 5765(defun interactive-p () 5766 "Return t if the containing function was run directly by user input. 5767This means that the function was called with `call-interactively' 5768\(which includes being called as the binding of a key) 5769and input is currently coming from the keyboard (not a keyboard macro), 5770and Emacs is not running in batch mode (`noninteractive' is nil). 5771 5772The only known proper use of `interactive-p' is in deciding whether to 5773display a helpful message, or how to display it. If you're thinking 5774of using it for any other purpose, it is quite likely that you're 5775making a mistake. Think: what do you want to do when the command is 5776called from a keyboard macro or in batch mode? 5777 5778To test whether your function was called with `call-interactively', 5779either (i) add an extra optional argument and give it an `interactive' 5780spec that specifies non-nil unconditionally (such as \"p\"); or (ii) 5781use `called-interactively-p'. 5782 5783To test whether a function can be called interactively, use 5784`commandp'." 5785 ;; Kept around for now. See discussion at: 5786 ;; https://lists.gnu.org/r/emacs-devel/2020-08/msg00564.html 5787 (declare (obsolete called-interactively-p "23.2")) 5788 (called-interactively-p 'interactive)) 5789 5790(defun internal-push-keymap (keymap symbol) 5791 (let ((map (symbol-value symbol))) 5792 (unless (memq keymap map) 5793 (unless (memq 'add-keymap-witness (symbol-value symbol)) 5794 (setq map (make-composed-keymap nil (symbol-value symbol))) 5795 (push 'add-keymap-witness (cdr map)) 5796 (set symbol map)) 5797 (push keymap (cdr map))))) 5798 5799(defun internal-pop-keymap (keymap symbol) 5800 (let ((map (symbol-value symbol))) 5801 (when (memq keymap map) 5802 (setf (cdr map) (delq keymap (cdr map)))) 5803 (let ((tail (cddr map))) 5804 (and (or (null tail) (keymapp tail)) 5805 (eq 'add-keymap-witness (nth 1 map)) 5806 (set symbol tail))))) 5807 5808(define-obsolete-function-alias 5809 'set-temporary-overlay-map #'set-transient-map "24.4") 5810 5811(defun set-transient-map (map &optional keep-pred on-exit) 5812 "Set MAP as a temporary keymap taking precedence over other keymaps. 5813Normally, MAP is used only once, to look up the very next key. 5814However, if the optional argument KEEP-PRED is t, MAP stays 5815active if a key from MAP is used. KEEP-PRED can also be a 5816function of no arguments: it is called from `pre-command-hook' and 5817if it returns non-nil, then MAP stays active. 5818 5819Optional arg ON-EXIT, if non-nil, specifies a function that is 5820called, with no arguments, after MAP is deactivated. 5821 5822This uses `overriding-terminal-local-map', which takes precedence over all 5823other keymaps. As usual, if no match for a key is found in MAP, the normal 5824key lookup sequence then continues. 5825 5826This returns an \"exit function\", which can be called with no argument 5827to deactivate this transient map, regardless of KEEP-PRED." 5828 (let* ((clearfun (make-symbol "clear-transient-map")) 5829 (exitfun 5830 (lambda () 5831 (internal-pop-keymap map 'overriding-terminal-local-map) 5832 (remove-hook 'pre-command-hook clearfun) 5833 (when on-exit (funcall on-exit))))) 5834 ;; Don't use letrec, because equal (in add/remove-hook) could get trapped 5835 ;; in a cycle. (bug#46326) 5836 (fset clearfun 5837 (lambda () 5838 (with-demoted-errors "set-transient-map PCH: %S" 5839 (unless (cond 5840 ((null keep-pred) nil) 5841 ((and (not (eq map (cadr overriding-terminal-local-map))) 5842 (memq map (cddr overriding-terminal-local-map))) 5843 ;; There's presumably some other transient-map in 5844 ;; effect. Wait for that one to terminate before we 5845 ;; remove ourselves. 5846 ;; For example, if isearch and C-u both use transient 5847 ;; maps, then the lifetime of the C-u should be nested 5848 ;; within isearch's, so the pre-command-hook of 5849 ;; isearch should be suspended during the C-u one so 5850 ;; we don't exit isearch just because we hit 1 after 5851 ;; C-u and that 1 exits isearch whereas it doesn't 5852 ;; exit C-u. 5853 t) 5854 ((eq t keep-pred) 5855 (let ((mc (lookup-key map (this-command-keys-vector)))) 5856 ;; If the key is unbound `this-command` is 5857 ;; nil and so is `mc`. 5858 (and mc (eq this-command mc)))) 5859 (t (funcall keep-pred))) 5860 (funcall exitfun))))) 5861 (add-hook 'pre-command-hook clearfun) 5862 (internal-push-keymap map 'overriding-terminal-local-map) 5863 exitfun)) 5864 5865;;;; Progress reporters. 5866 5867;; Progress reporter has the following structure: 5868;; 5869;; (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME 5870;; MIN-VALUE 5871;; MAX-VALUE 5872;; MESSAGE 5873;; MIN-CHANGE 5874;; MIN-TIME 5875;; MESSAGE-SUFFIX]) 5876;; 5877;; This weirdness is for optimization reasons: we want 5878;; `progress-reporter-update' to be as fast as possible, so 5879;; `(car reporter)' is better than `(aref reporter 0)'. 5880;; 5881;; NEXT-UPDATE-TIME is a float. While `float-time' loses a couple 5882;; digits of precision, it doesn't really matter here. On the other 5883;; hand, it greatly simplifies the code. 5884 5885(defsubst progress-reporter-update (reporter &optional value suffix) 5886 "Report progress of an operation in the echo area. 5887REPORTER should be the result of a call to `make-progress-reporter'. 5888 5889If REPORTER is a numerical progress reporter---i.e. if it was 5890 made using non-nil MIN-VALUE and MAX-VALUE arguments to 5891 `make-progress-reporter'---then VALUE should be a number between 5892 MIN-VALUE and MAX-VALUE. 5893 5894Optional argument SUFFIX is a string to be displayed after 5895REPORTER's main message and progress text. If REPORTER is a 5896non-numerical reporter, then VALUE should be nil, or a string to 5897use instead of SUFFIX. 5898 5899This function is relatively inexpensive. If the change since 5900last update is too small or insufficient time has passed, it does 5901nothing." 5902 (when (or (not (numberp value)) ; For pulsing reporter 5903 (>= value (car reporter))) ; For numerical reporter 5904 (progress-reporter-do-update reporter value suffix))) 5905 5906(defun make-progress-reporter (message &optional min-value max-value 5907 current-value min-change min-time) 5908 "Return progress reporter object for use with `progress-reporter-update'. 5909 5910MESSAGE is shown in the echo area, with a status indicator 5911appended to the end. When you call `progress-reporter-done', the 5912word \"done\" is printed after the MESSAGE. You can change the 5913MESSAGE of an existing progress reporter by calling 5914`progress-reporter-force-update'. 5915 5916MIN-VALUE and MAX-VALUE, if non-nil, are starting (0% complete) 5917and final (100% complete) states of operation; the latter should 5918be larger. In this case, the status message shows the percentage 5919progress. 5920 5921If MIN-VALUE and/or MAX-VALUE is omitted or nil, the status 5922message shows a \"spinning\", non-numeric indicator. 5923 5924Optional CURRENT-VALUE is the initial progress; the default is 5925MIN-VALUE. 5926Optional MIN-CHANGE is the minimal change in percents to report; 5927the default is 1%. 5928CURRENT-VALUE and MIN-CHANGE do not have any effect if MIN-VALUE 5929and/or MAX-VALUE are nil. 5930 5931Optional MIN-TIME specifies the minimum interval time between 5932echo area updates (default is 0.2 seconds.) If the OS is not 5933capable of measuring fractions of seconds, this parameter is 5934effectively rounded up." 5935 (when (string-match "[[:alnum:]]\\'" message) 5936 (setq message (concat message "..."))) 5937 (unless min-time 5938 (setq min-time 0.2)) 5939 (let ((reporter 5940 ;; Force a call to `message' now 5941 (cons (or min-value 0) 5942 (vector (if (>= min-time 0.02) 5943 (float-time) nil) 5944 min-value 5945 max-value 5946 message 5947 (if min-change (max (min min-change 50) 1) 1) 5948 min-time 5949 ;; SUFFIX 5950 nil)))) 5951 (progress-reporter-update reporter (or current-value min-value)) 5952 reporter)) 5953 5954(defun progress-reporter-force-update (reporter &optional value new-message suffix) 5955 "Report progress of an operation in the echo area unconditionally. 5956 5957REPORTER, VALUE, and SUFFIX are the same as in `progress-reporter-update'. 5958NEW-MESSAGE, if non-nil, sets a new message for the reporter." 5959 (let ((parameters (cdr reporter))) 5960 (when new-message 5961 (aset parameters 3 new-message)) 5962 (when (aref parameters 0) 5963 (aset parameters 0 (float-time))) 5964 (progress-reporter-do-update reporter value suffix))) 5965 5966(defvar progress-reporter--pulse-characters ["-" "\\" "|" "/"] 5967 "Characters to use for pulsing progress reporters.") 5968 5969(defun progress-reporter-do-update (reporter value &optional suffix) 5970 (let* ((parameters (cdr reporter)) 5971 (update-time (aref parameters 0)) 5972 (min-value (aref parameters 1)) 5973 (max-value (aref parameters 2)) 5974 (text (aref parameters 3)) 5975 (enough-time-passed 5976 ;; See if enough time has passed since the last update. 5977 (or (not update-time) 5978 (when (time-less-p update-time nil) 5979 ;; Calculate time for the next update 5980 (aset parameters 0 (+ update-time (aref parameters 5))))))) 5981 (cond ((and min-value max-value) 5982 ;; Numerical indicator 5983 (let* ((one-percent (/ (- max-value min-value) 100.0)) 5984 (percentage (if (= max-value min-value) 5985 0 5986 (truncate (/ (- value min-value) 5987 one-percent))))) 5988 ;; Calculate NEXT-UPDATE-VALUE. If we are not printing 5989 ;; message because not enough time has passed, use 1 5990 ;; instead of MIN-CHANGE. This makes delays between echo 5991 ;; area updates closer to MIN-TIME. 5992 (setcar reporter 5993 (min (+ min-value (* (+ percentage 5994 (if enough-time-passed 5995 ;; MIN-CHANGE 5996 (aref parameters 4) 5997 1)) 5998 one-percent)) 5999 max-value)) 6000 (when (integerp value) 6001 (setcar reporter (ceiling (car reporter)))) 6002 ;; Print message only if enough time has passed 6003 (when enough-time-passed 6004 (if suffix 6005 (aset parameters 6 suffix) 6006 (setq suffix (or (aref parameters 6) ""))) 6007 (if (> percentage 0) 6008 (message "%s%d%% %s" text percentage suffix) 6009 (message "%s %s" text suffix))))) 6010 ;; Pulsing indicator 6011 (enough-time-passed 6012 (when (and value (not suffix)) 6013 (setq suffix value)) 6014 (if suffix 6015 (aset parameters 6 suffix) 6016 (setq suffix (or (aref parameters 6) ""))) 6017 (let* ((index (mod (1+ (car reporter)) 4)) 6018 (message-log-max nil) 6019 (pulse-char (aref progress-reporter--pulse-characters 6020 index))) 6021 (setcar reporter index) 6022 (message "%s %s %s" text pulse-char suffix)))))) 6023 6024(defun progress-reporter-done (reporter) 6025 "Print reporter's message followed by word \"done\" in echo area." 6026 (message "%sdone" (aref (cdr reporter) 3))) 6027 6028(defmacro dotimes-with-progress-reporter (spec reporter-or-message &rest body) 6029 "Loop a certain number of times and report progress in the echo area. 6030Evaluate BODY with VAR bound to successive integers running from 60310, inclusive, to COUNT, exclusive. Then evaluate RESULT to get 6032the return value (nil if RESULT is omitted). 6033 6034REPORTER-OR-MESSAGE is a progress reporter object or a string. In the latter 6035case, use this string to create a progress reporter. 6036 6037At each iteration, print the reporter message followed by progress 6038percentage in the echo area. After the loop is finished, 6039print the reporter message followed by the word \"done\". 6040 6041This macro is a convenience wrapper around `make-progress-reporter' and friends. 6042 6043\(fn (VAR COUNT [RESULT]) REPORTER-OR-MESSAGE BODY...)" 6044 (declare (indent 2) (debug ((symbolp form &optional form) form body))) 6045 (let ((prep (make-symbol "--dotimes-prep--")) 6046 (end (make-symbol "--dotimes-end--"))) 6047 `(let ((,prep ,reporter-or-message) 6048 (,end ,(cadr spec))) 6049 (when (stringp ,prep) 6050 (setq ,prep (make-progress-reporter ,prep 0 ,end))) 6051 (dotimes (,(car spec) ,end) 6052 ,@body 6053 (progress-reporter-update ,prep (1+ ,(car spec)))) 6054 (progress-reporter-done ,prep) 6055 (or ,@(cdr (cdr spec)) nil)))) 6056 6057(defmacro dolist-with-progress-reporter (spec reporter-or-message &rest body) 6058 "Loop over a list and report progress in the echo area. 6059Evaluate BODY with VAR bound to each car from LIST, in turn. 6060Then evaluate RESULT to get return value, default nil. 6061 6062REPORTER-OR-MESSAGE is a progress reporter object or a string. In the latter 6063case, use this string to create a progress reporter. 6064 6065At each iteration, print the reporter message followed by progress 6066percentage in the echo area. After the loop is finished, 6067print the reporter message followed by the word \"done\". 6068 6069\(fn (VAR LIST [RESULT]) REPORTER-OR-MESSAGE BODY...)" 6070 (declare (indent 2) (debug ((symbolp form &optional form) form body))) 6071 (let ((prep (make-symbol "--dolist-progress-reporter--")) 6072 (count (make-symbol "--dolist-count--")) 6073 (list (make-symbol "--dolist-list--"))) 6074 `(let ((,prep ,reporter-or-message) 6075 (,count 0) 6076 (,list ,(cadr spec))) 6077 (when (stringp ,prep) 6078 (setq ,prep (make-progress-reporter ,prep 0 (length ,list)))) 6079 (dolist (,(car spec) ,list) 6080 ,@body 6081 (progress-reporter-update ,prep (setq ,count (1+ ,count)))) 6082 (progress-reporter-done ,prep) 6083 (or ,@(cdr (cdr spec)) nil)))) 6084 6085 6086;;;; Comparing version strings. 6087 6088(defconst version-separator "." 6089 "Specify the string used to separate the version elements. 6090 6091Usually the separator is \".\", but it can be any other string.") 6092 6093 6094(defconst version-regexp-alist 6095 '(("^[-._+ ]?snapshot$" . -4) 6096 ;; treat "1.2.3-20050920" and "1.2-3" as snapshot releases 6097 ("^[-._+]$" . -4) 6098 ;; treat "1.2.3-CVS" as snapshot release 6099 ("^[-._+ ]?\\(cvs\\|git\\|bzr\\|svn\\|hg\\|darcs\\)$" . -4) 6100 ;; treat "-unknown" the same as snapshots. 6101 ("^[-._+ ]?unknown$" . -4) 6102 ("^[-._+ ]?alpha$" . -3) 6103 ("^[-._+ ]?beta$" . -2) 6104 ("^[-._+ ]?\\(pre\\|rc\\)$" . -1)) 6105 "Specify association between non-numeric version and its priority. 6106 6107This association is used to handle version string like \"1.0pre2\", 6108\"0.9alpha1\", etc. It's used by `version-to-list' (which see) to convert the 6109non-numeric part of a version string to an integer. For example: 6110 6111 String Version Integer List Version 6112 \"0.9snapshot\" (0 9 -4) 6113 \"1.0-git\" (1 0 -4) 6114 \"1.0.cvs\" (1 0 -4) 6115 \"1.0pre2\" (1 0 -1 2) 6116 \"1.0PRE2\" (1 0 -1 2) 6117 \"22.8beta3\" (22 8 -2 3) 6118 \"22.8 Beta3\" (22 8 -2 3) 6119 \"0.9alpha1\" (0 9 -3 1) 6120 \"0.9AlphA1\" (0 9 -3 1) 6121 \"0.9 alpha\" (0 9 -3) 6122 6123Each element has the following form: 6124 6125 (REGEXP . PRIORITY) 6126 6127Where: 6128 6129REGEXP regexp used to match non-numeric part of a version string. 6130 It should begin with the `^' anchor and end with a `$' to 6131 prevent false hits. Letter-case is ignored while matching 6132 REGEXP. 6133 6134PRIORITY a negative integer specifying non-numeric priority of REGEXP.") 6135 6136 6137(defun version-to-list (ver) 6138 "Convert version string VER into a list of integers. 6139 6140The version syntax is given by the following EBNF: 6141 6142 VERSION ::= NUMBER ( SEPARATOR NUMBER )*. 6143 6144 NUMBER ::= (0|1|2|3|4|5|6|7|8|9)+. 6145 6146 SEPARATOR ::= `version-separator' (which see) 6147 | `version-regexp-alist' (which see). 6148 6149The NUMBER part is optional if SEPARATOR is a match for an element 6150in `version-regexp-alist'. 6151 6152Examples of valid version syntax: 6153 6154 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1 6.9.30Beta 2.4.snapshot .5 6155 6156Examples of invalid version syntax: 6157 6158 1.0prepre2 1.0..7.5 22.8X3 alpha3.2 6159 6160Examples of version conversion: 6161 6162 Version String Version as a List of Integers 6163 \".5\" (0 5) 6164 \"0.9 alpha\" (0 9 -3) 6165 \"0.9AlphA1\" (0 9 -3 1) 6166 \"0.9snapshot\" (0 9 -4) 6167 \"1.0-git\" (1 0 -4) 6168 \"1.0.7.5\" (1 0 7 5) 6169 \"1.0.cvs\" (1 0 -4) 6170 \"1.0PRE2\" (1 0 -1 2) 6171 \"1.0pre2\" (1 0 -1 2) 6172 \"22.8 Beta3\" (22 8 -2 3) 6173 \"22.8beta3\" (22 8 -2 3) 6174 6175See documentation for `version-separator' and `version-regexp-alist'." 6176 (unless (stringp ver) 6177 (error "Version must be a string")) 6178 ;; Change .x.y to 0.x.y 6179 (if (and (>= (length ver) (length version-separator)) 6180 (string-equal (substring ver 0 (length version-separator)) 6181 version-separator)) 6182 (setq ver (concat "0" ver))) 6183 (unless (string-match-p "^[0-9]" ver) 6184 (error "Invalid version syntax: `%s' (must start with a number)" ver)) 6185 6186 (save-match-data 6187 (let ((i 0) 6188 (case-fold-search t) ; ignore case in matching 6189 lst s al) 6190 ;; Parse the version-string up to a separator until there are none left 6191 (while (and (setq s (string-match "[0-9]+" ver i)) 6192 (= s i)) 6193 ;; Add the numeric part to the beginning of the version list; 6194 ;; lst gets reversed at the end 6195 (setq lst (cons (string-to-number (substring ver i (match-end 0))) 6196 lst) 6197 i (match-end 0)) 6198 ;; handle non-numeric part 6199 (when (and (setq s (string-match "[^0-9]+" ver i)) 6200 (= s i)) 6201 (setq s (substring ver i (match-end 0)) 6202 i (match-end 0)) 6203 ;; handle alpha, beta, pre, etc. separator 6204 (unless (string= s version-separator) 6205 (setq al version-regexp-alist) 6206 (while (and al (not (string-match (caar al) s))) 6207 (setq al (cdr al))) 6208 (cond (al 6209 (push (cdar al) lst)) 6210 ;; Convert 22.3a to 22.3.1, 22.3b to 22.3.2, etc., but only if 6211 ;; the letter is the end of the version-string, to avoid 6212 ;; 22.8X3 being valid 6213 ((and (string-match "^[-._+ ]?\\([a-zA-Z]\\)$" s) 6214 (= i (length ver))) 6215 (push (- (aref (downcase (match-string 1 s)) 0) ?a -1) 6216 lst)) 6217 (t (error "Invalid version syntax: `%s'" ver)))))) 6218 (nreverse lst)))) 6219 6220(defun version-list-< (l1 l2) 6221 "Return t if L1, a list specification of a version, is lower than L2. 6222 6223Note that a version specified by the list (1) is equal to (1 0), 6224\(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant. 6225Also, a version given by the list (1) is higher than (1 -1), which in 6226turn is higher than (1 -2), which is higher than (1 -3)." 6227 (while (and l1 l2 (= (car l1) (car l2))) 6228 (setq l1 (cdr l1) 6229 l2 (cdr l2))) 6230 (cond 6231 ;; l1 not null and l2 not null 6232 ((and l1 l2) (< (car l1) (car l2))) 6233 ;; l1 null and l2 null ==> l1 length = l2 length 6234 ((and (null l1) (null l2)) nil) 6235 ;; l1 not null and l2 null ==> l1 length > l2 length 6236 (l1 (< (version-list-not-zero l1) 0)) 6237 ;; l1 null and l2 not null ==> l2 length > l1 length 6238 (t (< 0 (version-list-not-zero l2))))) 6239 6240 6241(defun version-list-= (l1 l2) 6242 "Return t if L1, a list specification of a version, is equal to L2. 6243 6244Note that a version specified by the list (1) is equal to (1 0), 6245\(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant. 6246Also, a version given by the list (1) is higher than (1 -1), which in 6247turn is higher than (1 -2), which is higher than (1 -3)." 6248 (while (and l1 l2 (= (car l1) (car l2))) 6249 (setq l1 (cdr l1) 6250 l2 (cdr l2))) 6251 (cond 6252 ;; l1 not null and l2 not null 6253 ((and l1 l2) nil) 6254 ;; l1 null and l2 null ==> l1 length = l2 length 6255 ((and (null l1) (null l2))) 6256 ;; l1 not null and l2 null ==> l1 length > l2 length 6257 (l1 (zerop (version-list-not-zero l1))) 6258 ;; l1 null and l2 not null ==> l2 length > l1 length 6259 (t (zerop (version-list-not-zero l2))))) 6260 6261 6262(defun version-list-<= (l1 l2) 6263 "Return t if L1, a list specification of a version, is lower or equal to L2. 6264 6265Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0), 6266etc. That is, the trailing zeroes are insignificant. Also, integer 6267list (1) is greater than (1 -1) which is greater than (1 -2) 6268which is greater than (1 -3)." 6269 (while (and l1 l2 (= (car l1) (car l2))) 6270 (setq l1 (cdr l1) 6271 l2 (cdr l2))) 6272 (cond 6273 ;; l1 not null and l2 not null 6274 ((and l1 l2) (< (car l1) (car l2))) 6275 ;; l1 null and l2 null ==> l1 length = l2 length 6276 ((and (null l1) (null l2))) 6277 ;; l1 not null and l2 null ==> l1 length > l2 length 6278 (l1 (<= (version-list-not-zero l1) 0)) 6279 ;; l1 null and l2 not null ==> l2 length > l1 length 6280 (t (<= 0 (version-list-not-zero l2))))) 6281 6282(defun version-list-not-zero (lst) 6283 "Return the first non-zero element of LST, which is a list of integers. 6284 6285If all LST elements are zeros or LST is nil, return zero." 6286 (while (and lst (zerop (car lst))) 6287 (setq lst (cdr lst))) 6288 (if lst 6289 (car lst) 6290 ;; there is no element different of zero 6291 0)) 6292 6293 6294(defun version< (v1 v2) 6295 "Return t if version V1 is lower (older) than V2. 6296 6297Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\", 6298etc. That is, the trailing \".0\"s are insignificant. Also, version 6299string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\", 6300which is higher than \"1alpha\", which is higher than \"1snapshot\". 6301Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions." 6302 (version-list-< (version-to-list v1) (version-to-list v2))) 6303 6304(defun version<= (v1 v2) 6305 "Return t if version V1 is lower (older) than or equal to V2. 6306 6307Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\", 6308etc. That is, the trailing \".0\"s are insignificant. Also, version 6309string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\", 6310which is higher than \"1alpha\", which is higher than \"1snapshot\". 6311Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions." 6312 (version-list-<= (version-to-list v1) (version-to-list v2))) 6313 6314(defun version= (v1 v2) 6315 "Return t if version V1 is equal to V2. 6316 6317Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\", 6318etc. That is, the trailing \".0\"s are insignificant. Also, version 6319string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\", 6320which is higher than \"1alpha\", which is higher than \"1snapshot\". 6321Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions." 6322 (version-list-= (version-to-list v1) (version-to-list v2))) 6323 6324(defvar package--builtin-versions 6325 ;; Mostly populated by loaddefs.el via autoload-builtin-package-versions. 6326 (purecopy `((emacs . ,(version-to-list emacs-version)))) 6327 "Alist giving the version of each versioned builtin package. 6328I.e. each element of the list is of the form (NAME . VERSION) where 6329NAME is the package name as a symbol, and VERSION is its version 6330as a list.") 6331 6332(defun package--description-file (dir) 6333 "Return package description file name for package DIR." 6334 (concat (let ((subdir (file-name-nondirectory 6335 (directory-file-name dir)))) 6336 (if (string-match "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)" subdir) 6337 (match-string 1 subdir) subdir)) 6338 "-pkg.el")) 6339 6340 6341;;; Thread support. 6342 6343(defmacro with-mutex (mutex &rest body) 6344 "Invoke BODY with MUTEX held, releasing MUTEX when done. 6345This is the simplest safe way to acquire and release a mutex." 6346 (declare (indent 1) (debug t)) 6347 (let ((sym (make-symbol "mutex"))) 6348 `(let ((,sym ,mutex)) 6349 (mutex-lock ,sym) 6350 (unwind-protect 6351 (progn ,@body) 6352 (mutex-unlock ,sym))))) 6353 6354 6355;;; Apropos. 6356 6357(defun apropos-internal (regexp &optional predicate) 6358 "Show all symbols whose names contain match for REGEXP. 6359If optional 2nd arg PREDICATE is non-nil, (funcall PREDICATE SYMBOL) is done 6360for each symbol and a symbol is mentioned only if that returns non-nil. 6361Return list of symbols found." 6362 (let (found) 6363 (mapatoms (lambda (symbol) 6364 (when (and (string-match regexp (symbol-name symbol)) 6365 (or (not predicate) 6366 (funcall predicate symbol))) 6367 (push symbol found)))) 6368 (sort found #'string-lessp))) 6369 6370 6371;;; Misc. 6372 6373(defvar definition-prefixes (make-hash-table :test 'equal) 6374 "Hash table mapping prefixes to the files in which they're used. 6375This can be used to automatically fetch not-yet-loaded definitions. 6376More specifically, if there is a value of the form (FILES...) for 6377a string PREFIX it means that the FILES define variables or functions 6378with names that start with PREFIX. 6379 6380Note that it does not imply that all definitions starting with PREFIX can 6381be found in those files. E.g. if prefix is \"gnus-article-\" there might 6382still be definitions of the form \"gnus-article-toto-titi\" in other files, 6383which would presumably appear in this table under another prefix such as 6384\"gnus-\" or \"gnus-article-toto-\".") 6385 6386(defun register-definition-prefixes (file prefixes) 6387 "Register that FILE uses PREFIXES." 6388 (dolist (prefix prefixes) 6389 (puthash prefix (cons file (gethash prefix definition-prefixes)) 6390 definition-prefixes))) 6391 6392(defconst menu-bar-separator '("--") 6393 "Separator for menus.") 6394 6395;; The following statement ought to be in print.c, but `provide' can't 6396;; be used there. 6397;; https://lists.gnu.org/r/emacs-devel/2009-08/msg00236.html 6398(when (hash-table-p (car (read-from-string 6399 (prin1-to-string (make-hash-table))))) 6400 (provide 'hashtable-print-readable)) 6401 6402;; This is used in lisp/Makefile.in and in leim/Makefile.in to 6403;; generate file names for autoloads, custom-deps, and finder-data. 6404(defun unmsys--file-name (file) 6405 "Produce the canonical file name for FILE from its MSYS form. 6406 6407On systems other than MS-Windows, just returns FILE. 6408On MS-Windows, converts /d/foo/bar form of file names 6409passed by MSYS Make into d:/foo/bar that Emacs can grok. 6410 6411This function is called from lisp/Makefile and leim/Makefile." 6412 (when (and (eq system-type 'windows-nt) 6413 (string-match "\\`/[a-zA-Z]/" file)) 6414 (setq file (concat (substring file 1 2) ":" (substring file 2)))) 6415 file) 6416 6417(defun flatten-tree (tree) 6418 "Return a \"flattened\" copy of TREE. 6419In other words, return a list of the non-nil terminal nodes, or 6420leaves, of the tree of cons cells rooted at TREE. Leaves in the 6421returned list are in the same order as in TREE. 6422 6423\(flatten-tree \\='(1 (2 . 3) nil (4 5 (6)) 7)) 6424=> (1 2 3 4 5 6 7)" 6425 (let (elems) 6426 (while (consp tree) 6427 (let ((elem (pop tree))) 6428 (while (consp elem) 6429 (push (cdr elem) tree) 6430 (setq elem (car elem))) 6431 (if elem (push elem elems)))) 6432 (if tree (push tree elems)) 6433 (nreverse elems))) 6434 6435;; Technically, `flatten-list' is a misnomer, but we provide it here 6436;; for discoverability: 6437(defalias 'flatten-list #'flatten-tree) 6438 6439(defun string-trim-left (string &optional regexp) 6440 "Trim STRING of leading string matching REGEXP. 6441 6442REGEXP defaults to \"[ \\t\\n\\r]+\"." 6443 (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string) 6444 (substring string (match-end 0)) 6445 string)) 6446 6447(defun string-trim-right (string &optional regexp) 6448 "Trim STRING of trailing string matching REGEXP. 6449 6450REGEXP defaults to \"[ \\t\\n\\r]+\"." 6451 (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") 6452 string))) 6453 (if i (substring string 0 i) string))) 6454 6455(defun string-trim (string &optional trim-left trim-right) 6456 "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT. 6457 6458TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." 6459 (string-trim-left (string-trim-right string trim-right) trim-left)) 6460 6461;; The initial anchoring is for better performance in searching matches. 6462(defconst regexp-unmatchable "\\`a\\`" 6463 "Standard regexp guaranteed not to match any string at all.") 6464 6465(defun run-hook-query-error-with-timeout (hook) 6466 "Run HOOK, catching errors, and querying the user about whether to continue. 6467If a function in HOOK signals an error, the user will be prompted 6468whether to continue or not. If the user doesn't respond, 6469evaluation will continue if the user doesn't respond within five 6470seconds." 6471 (run-hook-wrapped 6472 hook 6473 (lambda (fun) 6474 (condition-case err 6475 (funcall fun) 6476 (error 6477 (unless (y-or-n-p-with-timeout (format "Error %s; continue?" err) 6478 5 t) 6479 (error err)))) 6480 ;; Continue running. 6481 nil))) 6482 6483(defun internal--fill-string-single-line (str) 6484 "Fill string STR to `fill-column'. 6485This is intended for very simple filling while bootstrapping 6486Emacs itself, and does not support all the customization options 6487of fill.el (for example `fill-region')." 6488 (if (< (length str) fill-column) 6489 str 6490 (let* ((limit (min fill-column (length str))) 6491 (fst (substring str 0 limit)) 6492 (lst (substring str limit))) 6493 (cond ((string-match "\\( \\)$" fst) 6494 (setq fst (replace-match "\n" nil nil fst 1))) 6495 ((string-match "^ \\(.*\\)" lst) 6496 (setq fst (concat fst "\n")) 6497 (setq lst (match-string 1 lst))) 6498 ((string-match ".*\\( \\(.+\\)\\)$" fst) 6499 (setq lst (concat (match-string 2 fst) lst)) 6500 (setq fst (replace-match "\n" nil nil fst 1)))) 6501 (concat fst (internal--fill-string-single-line lst))))) 6502 6503(defun internal--format-docstring-line (string &rest objects) 6504 "Format a single line from a documentation string out of STRING and OBJECTS. 6505Signal an error if STRING contains a newline. 6506This is intended for internal use only. Avoid using this for the 6507first line of a docstring; the first line should be a complete 6508sentence (see Info node `(elisp) Documentation Tips')." 6509 (when (string-match "\n" string) 6510 (error "Unable to fill string containing newline: %S" string)) 6511 (internal--fill-string-single-line (apply #'format string objects))) 6512 6513(defun json-available-p () 6514 "Return non-nil if Emacs has libjansson support." 6515 (and (fboundp 'json-serialize) 6516 (condition-case nil 6517 (json-serialize t) 6518 (:success t) 6519 (json-unavailable nil)))) 6520 6521(defun ensure-list (object) 6522 "Return OBJECT as a list. 6523If OBJECT is already a list, return OBJECT itself. If it's 6524not a list, return a one-element list containing OBJECT." 6525 (if (listp object) 6526 object 6527 (list object))) 6528 6529(defun define-keymap--compile (form &rest args) 6530 ;; This compiler macro is only there for compile-time 6531 ;; error-checking; it does not change the call in any way. 6532 (while (and args 6533 (keywordp (car args)) 6534 (not (eq (car args) :menu))) 6535 (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix)) 6536 (byte-compile-warn "Invalid keyword: %s" (car args))) 6537 (setq args (cdr args)) 6538 (when (null args) 6539 (byte-compile-warn "Uneven number of keywords in %S" form)) 6540 (setq args (cdr args))) 6541 ;; Bindings. 6542 (while args 6543 (let ((key (pop args))) 6544 (when (and (stringp key) (not (key-valid-p key))) 6545 (byte-compile-warn "Invalid `kbd' syntax: %S" key))) 6546 (when (null args) 6547 (byte-compile-warn "Uneven number of key bindings in %S" form)) 6548 (setq args (cdr args))) 6549 form) 6550 6551(defun define-keymap (&rest definitions) 6552 "Create a new keymap and define KEY/DEFINITION pairs as key bindings. 6553The new keymap is returned. 6554 6555Options can be given as keywords before the KEY/DEFINITION 6556pairs. Available keywords are: 6557 6558:full If non-nil, create a chartable alist (see `make-keymap'). 6559 If nil (i.e., the default), create a sparse keymap (see 6560 `make-sparse-keymap'). 6561 6562:suppress If non-nil, the keymap will be suppressed (see `suppress-keymap'). 6563 If `nodigits', treat digits like other chars. 6564 6565:parent If non-nil, this should be a keymap to use as the parent 6566 (see `set-keymap-parent'). 6567 6568:keymap If non-nil, instead of creating a new keymap, the given keymap 6569 will be destructively modified instead. 6570 6571:name If non-nil, this should be a string to use as the menu for 6572 the keymap in case you use it as a menu with `x-popup-menu'. 6573 6574:prefix If non-nil, this should be a symbol to be used as a prefix 6575 command (see `define-prefix-command'). If this is the case, 6576 this symbol is returned instead of the map itself. 6577 6578KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can 6579also be the special symbol `:menu', in which case DEFINITION 6580should be a MENU form as accepted by `easy-menu-define'. 6581 6582\(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" 6583 (declare (indent defun) 6584 (compiler-macro define-keymap--compile)) 6585 (let (full suppress parent name prefix keymap) 6586 ;; Handle keywords. 6587 (while (and definitions 6588 (keywordp (car definitions)) 6589 (not (eq (car definitions) :menu))) 6590 (let ((keyword (pop definitions))) 6591 (unless definitions 6592 (error "Missing keyword value for %s" keyword)) 6593 (let ((value (pop definitions))) 6594 (pcase keyword 6595 (:full (setq full value)) 6596 (:keymap (setq keymap value)) 6597 (:parent (setq parent value)) 6598 (:suppress (setq suppress value)) 6599 (:name (setq name value)) 6600 (:prefix (setq prefix value)) 6601 (_ (error "Invalid keyword: %s" keyword)))))) 6602 6603 (when (and prefix 6604 (or full parent suppress keymap)) 6605 (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords")) 6606 6607 (when (and keymap full) 6608 (error "Invalid combination: :keymap with :full")) 6609 6610 (let ((keymap (cond 6611 (keymap keymap) 6612 (prefix (define-prefix-command prefix nil name)) 6613 (full (make-keymap name)) 6614 (t (make-sparse-keymap name))))) 6615 (when suppress 6616 (suppress-keymap keymap (eq suppress 'nodigits))) 6617 (when parent 6618 (set-keymap-parent keymap parent)) 6619 6620 ;; Do the bindings. 6621 (while definitions 6622 (let ((key (pop definitions))) 6623 (unless definitions 6624 (error "Uneven number of key/definition pairs")) 6625 (let ((def (pop definitions))) 6626 (if (eq key :menu) 6627 (easy-menu-define nil keymap "" def) 6628 (keymap-set keymap key def))))) 6629 keymap))) 6630 6631(defmacro defvar-keymap (variable-name &rest defs) 6632 "Define VARIABLE-NAME as a variable with a keymap definition. 6633See `define-keymap' for an explanation of the keywords and KEY/DEFINITION. 6634 6635In addition to the keywords accepted by `define-keymap', this 6636macro also accepts a `:doc' keyword, which (if present) is used 6637as the variable documentation string. 6638 6639\(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" 6640 (declare (indent 1)) 6641 (let ((opts nil) 6642 doc) 6643 (while (and defs 6644 (keywordp (car defs)) 6645 (not (eq (car defs) :menu))) 6646 (let ((keyword (pop defs))) 6647 (unless defs 6648 (error "Uneven number of keywords")) 6649 (if (eq keyword :doc) 6650 (setq doc (pop defs)) 6651 (push keyword opts) 6652 (push (pop defs) opts)))) 6653 (unless (zerop (% (length defs) 2)) 6654 (error "Uneven number of key/definition pairs: %s" defs)) 6655 `(defvar ,variable-name 6656 (define-keymap ,@(nreverse opts) ,@defs) 6657 ,@(and doc (list doc))))) 6658 6659(defmacro with-delayed-message (args &rest body) 6660 "Like `progn', but display MESSAGE if BODY takes longer than TIMEOUT seconds. 6661The MESSAGE form will be evaluated immediately, but the resulting 6662string will be displayed only if BODY takes longer than TIMEOUT seconds. 6663 6664\(fn (timeout message) &rest body)" 6665 (declare (indent 1)) 6666 `(funcall-with-delayed-message ,(car args) ,(cadr args) 6667 (lambda () 6668 ,@body))) 6669 6670;;; subr.el ends here 6671