* lisp/calendar/diary-lib.el (diary-mode): Refresh *Calendar* after
[bpt/emacs.git] / lisp / subr.el
CommitLineData
c88ab9ce 1;;; subr.el --- basic lisp subroutines for Emacs
630cc463 2
a8a64811 3;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
3226d6ca
GM
4;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
5;; Free Software Foundation, Inc.
be9b65ac 6
30764597
PJ
7;; Maintainer: FSF
8;; Keywords: internal
bd78fa1d 9;; Package: emacs
30764597 10
be9b65ac
DL
11;; This file is part of GNU Emacs.
12
eb3fa2cf 13;; GNU Emacs is free software: you can redistribute it and/or modify
be9b65ac 14;; it under the terms of the GNU General Public License as published by
eb3fa2cf
GM
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
be9b65ac
DL
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
eb3fa2cf 24;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
be9b65ac 25
60370d40
PJ
26;;; Commentary:
27
630cc463 28;;; Code:
d0fc47ed 29
77a5664f
RS
30(defvar custom-declare-variable-list nil
31 "Record `defcustom' calls made before `custom.el' is loaded to handle them.
32Each element of this list holds the arguments to one call to `defcustom'.")
33
68e3e5f5 34;; Use this, rather than defcustom, in subr.el and other files loaded
77a5664f
RS
35;; before custom.el.
36(defun custom-declare-variable-early (&rest arguments)
37 (setq custom-declare-variable-list
38 (cons arguments custom-declare-variable-list)))
2c642c03 39
708bb6f8
RS
40(defmacro declare-function (fn file &optional arglist fileonly)
41 "Tell the byte-compiler that function FN is defined, in FILE.
42Optional ARGLIST is the argument list used by the function. The
43FILE argument is not used by the byte-compiler, but by the
44`check-declare' package, which checks that FILE contains a
45definition for FN. ARGLIST is used by both the byte-compiler and
46`check-declare' to check for consistency.
47
48FILE can be either a Lisp file (in which case the \".el\"
49extension is optional), or a C file. C files are expanded
50relative to the Emacs \"src/\" directory. Lisp files are
51searched for using `locate-library', and if that fails they are
52expanded relative to the location of the file containing the
53declaration. A FILE with an \"ext:\" prefix is an external file.
54`check-declare' will check such files if they are found, and skip
55them without error if they are not.
56
57FILEONLY non-nil means that `check-declare' will only check that
58FILE exists, not that it defines FN. This is intended for
59function-definitions that `check-declare' does not recognize, e.g.
60`defstruct'.
61
62To specify a value for FILEONLY without passing an argument list,
63set ARGLIST to `t'. This is necessary because `nil' means an
64empty argument list, rather than an unspecified one.
65
66Note that for the purposes of `check-declare', this statement
a4d2c321 67must be the first non-whitespace on a line.
708bb6f8 68
83031738 69For more information, see Info node `(elisp)Declaring Functions'."
708bb6f8
RS
70 ;; Does nothing - byte-compile-declare-function does the work.
71 nil)
e224699a 72
2c642c03 73\f
c4f484f2 74;;;; Basic Lisp macros.
9a5336ae 75
0764e16f
SM
76(defalias 'not 'null)
77
6b61353c 78(defmacro noreturn (form)
70c6db6c
LT
79 "Evaluate FORM, expecting it not to return.
80If FORM does return, signal an error."
6b61353c
KH
81 `(prog1 ,form
82 (error "Form marked with `noreturn' did return")))
83
84(defmacro 1value (form)
70c6db6c
LT
85 "Evaluate FORM, expecting a constant return value.
86This is the global do-nothing version. There is also `testcover-1value'
87that complains if FORM ever does return differing values."
6b61353c
KH
88 form)
89
8285ccd2
RS
90(defmacro def-edebug-spec (symbol spec)
91 "Set the `edebug-form-spec' property of SYMBOL according to SPEC.
e32721f5
GM
92Both SYMBOL and SPEC are unevaluated. The SPEC can be:
930 (instrument no arguments); t (instrument all arguments);
94a symbol (naming a function with an Edebug specification); or a list.
95The elements of the list describe the argument types; see
96\(info \"(elisp)Specification List\") for details."
8285ccd2
RS
97 `(put (quote ,symbol) 'edebug-form-spec (quote ,spec)))
98
9a5336ae
JB
99(defmacro lambda (&rest cdr)
100 "Return a lambda expression.
101A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
102self-quoting; the result of evaluating the lambda expression is the
103expression itself. The lambda expression may then be treated as a
bec0d7f9 104function, i.e., stored as the function value of a symbol, passed to
265b3f2a 105`funcall' or `mapcar', etc.
bec0d7f9 106
9a5336ae 107ARGS should take the same form as an argument list for a `defun'.
8fd68088
RS
108DOCSTRING is an optional documentation string.
109 If present, it should describe how to call the function.
110 But documentation strings are usually not useful in nameless functions.
9a5336ae
JB
111INTERACTIVE should be a call to the function `interactive', which see.
112It may also be omitted.
a478f3e1
JB
113BODY should be a list of Lisp expressions.
114
115\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
9a5336ae
JB
116 ;; Note that this definition should not use backquotes; subr.el should not
117 ;; depend on backquote.el.
118 (list 'function (cons 'lambda cdr)))
119
a69c67e8
CY
120(if (null (featurep 'cl))
121 (progn
354f0faf
SM
122 ;; If we reload subr.el after having loaded CL, be careful not to
123 ;; overwrite CL's extended definition of `dolist', `dotimes',
124 ;; `declare', `push' and `pop'.
1be152fc 125(defmacro push (newelt listname)
fa65505b 126 "Add NEWELT to the list stored in the symbol LISTNAME.
1be152fc 127This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
d270117a 128LISTNAME must be a symbol."
f30e0cd8 129 (declare (debug (form sexp)))
22d85d00 130 (list 'setq listname
354f0faf 131 (list 'cons newelt listname)))
d270117a
RS
132
133(defmacro pop (listname)
134 "Return the first element of LISTNAME's value, and remove it from the list.
135LISTNAME must be a symbol whose value is a list.
136If the value is nil, `pop' returns nil but does not actually
137change the list."
f30e0cd8 138 (declare (debug (sexp)))
54993fa4 139 (list 'car
354f0faf 140 (list 'prog1 listname
a69c67e8
CY
141 (list 'setq listname (list 'cdr listname)))))
142))
d270117a 143
debff3c3 144(defmacro when (cond &rest body)
7f67eea0
KS
145 "If COND yields non-nil, do BODY, else return nil.
146When COND yields non-nil, eval BODY forms sequentially and return
147value of last one, or nil if there are none.
148
ebc3ae14 149\(fn COND BODY...)"
d47f7515 150 (declare (indent 1) (debug t))
debff3c3 151 (list 'if cond (cons 'progn body)))
9a5336ae 152
debff3c3 153(defmacro unless (cond &rest body)
7f67eea0
KS
154 "If COND yields nil, do BODY, else return nil.
155When COND yields nil, eval BODY forms sequentially and return
156value of last one, or nil if there are none.
157
ebc3ae14 158\(fn COND BODY...)"
d47f7515 159 (declare (indent 1) (debug t))
debff3c3 160 (cons 'if (cons cond (cons nil body))))
d370591d 161
a69c67e8
CY
162(if (null (featurep 'cl))
163 (progn
354f0faf
SM
164 ;; If we reload subr.el after having loaded CL, be careful not to
165 ;; overwrite CL's extended definition of `dolist', `dotimes',
166 ;; `declare', `push' and `pop'.
01d16e16
RS
167(defvar --dolist-tail-- nil
168 "Temporary variable used in `dolist' expansion.")
169
a0b0756a 170(defmacro dolist (spec &rest body)
d47f7515 171 "Loop over a list.
a0b0756a 172Evaluate BODY with VAR bound to each car from LIST, in turn.
d47f7515
SM
173Then evaluate RESULT to get return value, default nil.
174
d775d486 175\(fn (VAR LIST [RESULT]) BODY...)"
d47f7515 176 (declare (indent 1) (debug ((symbolp form &optional form) body)))
01d16e16
RS
177 ;; It would be cleaner to create an uninterned symbol,
178 ;; but that uses a lot more space when many functions in many files
179 ;; use dolist.
180 (let ((temp '--dolist-tail--))
d47f7515
SM
181 `(let ((,temp ,(nth 1 spec))
182 ,(car spec))
183 (while ,temp
184 (setq ,(car spec) (car ,temp))
01d16e16
RS
185 ,@body
186 (setq ,temp (cdr ,temp)))
d47f7515
SM
187 ,@(if (cdr (cdr spec))
188 `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))
a0b0756a 189
01d16e16
RS
190(defvar --dotimes-limit-- nil
191 "Temporary variable used in `dotimes' expansion.")
192
a0b0756a 193(defmacro dotimes (spec &rest body)
d47f7515 194 "Loop a certain number of times.
a0b0756a
RS
195Evaluate BODY with VAR bound to successive integers running from 0,
196inclusive, to COUNT, exclusive. Then evaluate RESULT to get
d47f7515
SM
197the return value (nil if RESULT is omitted).
198
d775d486 199\(fn (VAR COUNT [RESULT]) BODY...)"
d47f7515 200 (declare (indent 1) (debug dolist))
01d16e16
RS
201 ;; It would be cleaner to create an uninterned symbol,
202 ;; but that uses a lot more space when many functions in many files
203 ;; use dotimes.
204 (let ((temp '--dotimes-limit--)
d47f7515
SM
205 (start 0)
206 (end (nth 1 spec)))
207 `(let ((,temp ,end)
208 (,(car spec) ,start))
209 (while (< ,(car spec) ,temp)
210 ,@body
211 (setq ,(car spec) (1+ ,(car spec))))
212 ,@(cdr (cdr spec)))))
a0b0756a 213
6b61353c
KH
214(defmacro declare (&rest specs)
215 "Do not evaluate any arguments and return nil.
216Treated as a declaration when used at the right place in a
a478f3e1 217`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
a69c67e8
CY
218 nil)
219))
6b5de136
GM
220
221(defmacro ignore-errors (&rest body)
222 "Execute BODY; if an error occurs, return nil.
223Otherwise, return result of last form in BODY."
7467d0a8 224 (declare (debug t) (indent 0))
6b5de136 225 `(condition-case nil (progn ,@body) (error nil)))
c4f484f2
RS
226\f
227;;;; Basic Lisp functions.
228
229(defun ignore (&rest ignore)
230 "Do nothing and return nil.
231This function accepts any number of arguments, but ignores them."
232 (interactive)
233 nil)
234
fd6c5134 235;; Signal a compile-error if the first arg is missing.
c4f484f2
RS
236(defun error (&rest args)
237 "Signal an error, making error message by passing all args to `format'.
238In Emacs, the convention is that error messages start with a capital
239letter but *do not* end with a period. Please follow this convention
fd6c5134 240for the sake of consistency."
c4f484f2
RS
241 (while t
242 (signal 'error (list (apply 'format args)))))
f3a30a50 243(set-advertised-calling-convention 'error '(string &rest args) "23.1")
c4f484f2
RS
244
245;; We put this here instead of in frame.el so that it's defined even on
246;; systems where frame.el isn't loaded.
247(defun frame-configuration-p (object)
248 "Return non-nil if OBJECT seems to be a frame configuration.
249Any list whose car is `frame-configuration' is assumed to be a frame
250configuration."
251 (and (consp object)
252 (eq (car object) 'frame-configuration)))
253
254(defun functionp (object)
fc944cd4 255 "Non-nil if OBJECT is a function."
c4f484f2
RS
256 (or (and (symbolp object) (fboundp object)
257 (condition-case nil
258 (setq object (indirect-function object))
259 (error nil))
260 (eq (car-safe object) 'autoload)
261 (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
fc944cd4
SM
262 (and (subrp object)
263 ;; Filter out special forms.
264 (not (eq 'unevalled (cdr (subr-arity object)))))
265 (byte-code-function-p object)
c4f484f2 266 (eq (car-safe object) 'lambda)))
c4f484f2
RS
267\f
268;;;; List functions.
6b61353c 269
d370591d
RS
270(defsubst caar (x)
271 "Return the car of the car of X."
272 (car (car x)))
273
274(defsubst cadr (x)
275 "Return the car of the cdr of X."
276 (car (cdr x)))
277
278(defsubst cdar (x)
279 "Return the cdr of the car of X."
280 (cdr (car x)))
281
282(defsubst cddr (x)
283 "Return the cdr of the cdr of X."
284 (cdr (cdr x)))
e8c32c99 285
a478f3e1
JB
286(defun last (list &optional n)
287 "Return the last link of LIST. Its car is the last element.
288If LIST is nil, return nil.
289If N is non-nil, return the Nth-to-last link of LIST.
290If N is bigger than the length of LIST, return LIST."
369fba5f 291 (if n
10e4702a 292 (and (>= n 0)
88f427d5 293 (let ((m (safe-length list)))
35744400
IS
294 (if (< n m) (nthcdr (- m n) list) list)))
295 (and list
88f427d5 296 (nthcdr (1- (safe-length list)) list))))
526d204e 297
a478f3e1 298(defun butlast (list &optional n)
a3111ae4 299 "Return a copy of LIST with the last N elements removed."
a478f3e1
JB
300 (if (and n (<= n 0)) list
301 (nbutlast (copy-sequence list) n)))
1c1c65de 302
a478f3e1 303(defun nbutlast (list &optional n)
1c1c65de 304 "Modifies LIST to remove the last N elements."
a478f3e1 305 (let ((m (length list)))
1c1c65de
KH
306 (or n (setq n 1))
307 (and (< n m)
308 (progn
a478f3e1
JB
309 (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
310 list))))
1c1c65de 311
6b61353c
KH
312(defun delete-dups (list)
313 "Destructively remove `equal' duplicates from LIST.
314Store the result in LIST and return it. LIST must be a proper list.
315Of several `equal' occurrences of an element in LIST, the first
316one is kept."
317 (let ((tail list))
318 (while tail
319 (setcdr tail (delete (car tail) (cdr tail)))
320 (setq tail (cdr tail))))
321 list)
322
0ed2c9b6 323(defun number-sequence (from &optional to inc)
abd9177a 324 "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
6b61353c
KH
325INC is the increment used between numbers in the sequence and defaults to 1.
326So, the Nth element of the list is \(+ FROM \(* N INC)) where N counts from
327zero. TO is only included if there is an N for which TO = FROM + N * INC.
328If TO is nil or numerically equal to FROM, return \(FROM).
329If INC is positive and TO is less than FROM, or INC is negative
330and TO is larger than FROM, return nil.
331If INC is zero and TO is neither nil nor numerically equal to
332FROM, signal an error.
333
334This function is primarily designed for integer arguments.
335Nevertheless, FROM, TO and INC can be integer or float. However,
336floating point arithmetic is inexact. For instance, depending on
337the machine, it may quite well happen that
338\(number-sequence 0.4 0.6 0.2) returns the one element list \(0.4),
339whereas \(number-sequence 0.4 0.8 0.2) returns a list with three
340elements. Thus, if some of the arguments are floats and one wants
341to make sure that TO is included, one may have to explicitly write
342TO as \(+ FROM \(* N INC)) or use a variable whose value was
343computed with this exact expression. Alternatively, you can,
344of course, also replace TO with a slightly larger value
345\(or a slightly more negative value if INC is negative)."
346 (if (or (not to) (= from to))
0ed2c9b6
VJL
347 (list from)
348 (or inc (setq inc 1))
6b61353c
KH
349 (when (zerop inc) (error "The increment can not be zero"))
350 (let (seq (n 0) (next from))
351 (if (> inc 0)
352 (while (<= next to)
353 (setq seq (cons next seq)
354 n (1+ n)
355 next (+ from (* n inc))))
356 (while (>= next to)
357 (setq seq (cons next seq)
358 n (1+ n)
359 next (+ from (* n inc)))))
0ed2c9b6 360 (nreverse seq))))
abd9177a 361
a176c9eb
CW
362(defun copy-tree (tree &optional vecp)
363 "Make a copy of TREE.
364If TREE is a cons cell, this recursively copies both its car and its cdr.
cfebd4db 365Contrast to `copy-sequence', which copies only along the cdrs. With second
a176c9eb
CW
366argument VECP, this copies vectors as well as conses."
367 (if (consp tree)
cfebd4db
RS
368 (let (result)
369 (while (consp tree)
370 (let ((newcar (car tree)))
371 (if (or (consp (car tree)) (and vecp (vectorp (car tree))))
372 (setq newcar (copy-tree (car tree) vecp)))
373 (push newcar result))
374 (setq tree (cdr tree)))
68b08950 375 (nconc (nreverse result) tree))
a176c9eb
CW
376 (if (and vecp (vectorp tree))
377 (let ((i (length (setq tree (copy-sequence tree)))))
378 (while (>= (setq i (1- i)) 0)
cfebd4db
RS
379 (aset tree i (copy-tree (aref tree i) vecp)))
380 tree)
381 tree)))
c4f484f2
RS
382\f
383;;;; Various list-search functions.
a176c9eb 384
8a288450
RS
385(defun assoc-default (key alist &optional test default)
386 "Find object KEY in a pseudo-alist ALIST.
753bc4f6
CY
387ALIST is a list of conses or objects. Each element
388 (or the element's car, if it is a cons) is compared with KEY by
389 calling TEST, with two arguments: (i) the element or its car,
390 and (ii) KEY.
391If that is non-nil, the element matches; then `assoc-default'
392 returns the element's cdr, if it is a cons, or DEFAULT if the
393 element is not a cons.
8a288450
RS
394
395If no element matches, the value is nil.
396If TEST is omitted or nil, `equal' is used."
397 (let (found (tail alist) value)
398 (while (and tail (not found))
399 (let ((elt (car tail)))
400 (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
401 (setq found t value (if (consp elt) (cdr elt) default))))
402 (setq tail (cdr tail)))
403 value))
98aae5f6 404
2b69ccfd 405(make-obsolete 'assoc-ignore-case 'assoc-string "22.1")
98aae5f6
KH
406(defun assoc-ignore-case (key alist)
407 "Like `assoc', but ignores differences in case and text representation.
408KEY must be a string. Upper-case and lower-case letters are treated as equal.
409Unibyte strings are converted to multibyte for comparison."
6b61353c 410 (assoc-string key alist t))
98aae5f6 411
2b69ccfd 412(make-obsolete 'assoc-ignore-representation 'assoc-string "22.1")
98aae5f6
KH
413(defun assoc-ignore-representation (key alist)
414 "Like `assoc', but ignores differences in text representation.
264ef586 415KEY must be a string.
98aae5f6 416Unibyte strings are converted to multibyte for comparison."
6b61353c 417 (assoc-string key alist nil))
cbbc3205
GM
418
419(defun member-ignore-case (elt list)
5612fd08 420 "Like `member', but ignore differences in case and text representation.
cbbc3205 421ELT must be a string. Upper-case and lower-case letters are treated as equal.
d86a3084
RS
422Unibyte strings are converted to multibyte for comparison.
423Non-strings in LIST are ignored."
424 (while (and list
425 (not (and (stringp (car list))
426 (eq t (compare-strings elt 0 nil (car list) 0 nil t)))))
242c13e8
MB
427 (setq list (cdr list)))
428 list)
cbbc3205 429
c4f484f2
RS
430(defun assq-delete-all (key alist)
431 "Delete from ALIST all elements whose car is `eq' to KEY.
432Return the modified alist.
433Elements of ALIST that are not conses are ignored."
434 (while (and (consp (car alist))
435 (eq (car (car alist)) key))
436 (setq alist (cdr alist)))
437 (let ((tail alist) tail-cdr)
438 (while (setq tail-cdr (cdr tail))
439 (if (and (consp (car tail-cdr))
440 (eq (car (car tail-cdr)) key))
441 (setcdr tail (cdr tail-cdr))
442 (setq tail tail-cdr))))
443 alist)
444
445(defun rassq-delete-all (value alist)
446 "Delete from ALIST all elements whose cdr is `eq' to VALUE.
447Return the modified alist.
448Elements of ALIST that are not conses are ignored."
449 (while (and (consp (car alist))
450 (eq (cdr (car alist)) value))
451 (setq alist (cdr alist)))
452 (let ((tail alist) tail-cdr)
453 (while (setq tail-cdr (cdr tail))
454 (if (and (consp (car tail-cdr))
455 (eq (cdr (car tail-cdr)) value))
456 (setcdr tail (cdr tail-cdr))
457 (setq tail tail-cdr))))
458 alist)
459
460(defun remove (elt seq)
461 "Return a copy of SEQ with all occurrences of ELT removed.
462SEQ must be a list, vector, or string. The comparison is done with `equal'."
463 (if (nlistp seq)
464 ;; If SEQ isn't a list, there's no need to copy SEQ because
465 ;; `delete' will return a new object.
466 (delete elt seq)
467 (delete elt (copy-sequence seq))))
468
469(defun remq (elt list)
470 "Return LIST with all occurrences of ELT removed.
471The comparison is done with `eq'. Contrary to `delq', this does not use
472side-effects, and the argument LIST is not modified."
473 (if (memq elt list)
474 (delq elt (copy-sequence list))
475 list))
9a5336ae 476\f
9a5336ae 477;;;; Keymap support.
be9b65ac 478
c4f484f2
RS
479(defmacro kbd (keys)
480 "Convert KEYS to the internal Emacs key representation.
481KEYS should be a string constant in the format used for
482saving keyboard macros (see `edmacro-mode')."
483 (read-kbd-macro keys))
484
be9b65ac
DL
485(defun undefined ()
486 (interactive)
487 (ding))
488
c4f484f2
RS
489;; Prevent the \{...} documentation construct
490;; from mentioning keys that run this command.
be9b65ac
DL
491(put 'undefined 'suppress-keymap t)
492
493(defun suppress-keymap (map &optional nodigits)
494 "Make MAP override all normally self-inserting keys to be undefined.
495Normally, as an exception, digits and minus-sign are set to make prefix args,
496but optional second arg NODIGITS non-nil treats them like other chars."
098ba983 497 (define-key map [remap self-insert-command] 'undefined)
be9b65ac
DL
498 (or nodigits
499 (let (loop)
500 (define-key map "-" 'negative-argument)
501 ;; Make plain numbers do numeric args.
502 (setq loop ?0)
503 (while (<= loop ?9)
504 (define-key map (char-to-string loop) 'digit-argument)
505 (setq loop (1+ loop))))))
506
4ced66fd 507(defun define-key-after (keymap key definition &optional after)
4434d61b
RS
508 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
509This is like `define-key' except that the binding for KEY is placed
510just after the binding for the event AFTER, instead of at the beginning
c34a9d34
RS
511of the map. Note that AFTER must be an event type (like KEY), NOT a command
512\(like DEFINITION).
513
4ced66fd 514If AFTER is t or omitted, the new binding goes at the end of the keymap.
08b1f8a1 515AFTER should be a single event type--a symbol or a character, not a sequence.
c34a9d34 516
4ced66fd 517Bindings are always added before any inherited map.
c34a9d34 518
4ced66fd
DL
519The order of bindings in a keymap matters when it is used as a menu."
520 (unless after (setq after t))
4434d61b
RS
521 (or (keymapp keymap)
522 (signal 'wrong-type-argument (list 'keymapp keymap)))
08b1f8a1
GM
523 (setq key
524 (if (<= (length key) 1) (aref key 0)
525 (setq keymap (lookup-key keymap
526 (apply 'vector
527 (butlast (mapcar 'identity key)))))
528 (aref key (1- (length key)))))
529 (let ((tail keymap) done inserted)
4434d61b
RS
530 (while (and (not done) tail)
531 ;; Delete any earlier bindings for the same key.
08b1f8a1 532 (if (eq (car-safe (car (cdr tail))) key)
4434d61b 533 (setcdr tail (cdr (cdr tail))))
08b1f8a1
GM
534 ;; If we hit an included map, go down that one.
535 (if (keymapp (car tail)) (setq tail (car tail)))
4434d61b
RS
536 ;; When we reach AFTER's binding, insert the new binding after.
537 ;; If we reach an inherited keymap, insert just before that.
113d28a8 538 ;; If we reach the end of this keymap, insert at the end.
c34a9d34
RS
539 (if (or (and (eq (car-safe (car tail)) after)
540 (not (eq after t)))
113d28a8
RS
541 (eq (car (cdr tail)) 'keymap)
542 (null (cdr tail)))
4434d61b 543 (progn
113d28a8
RS
544 ;; Stop the scan only if we find a parent keymap.
545 ;; Keep going past the inserted element
546 ;; so we can delete any duplications that come later.
547 (if (eq (car (cdr tail)) 'keymap)
548 (setq done t))
549 ;; Don't insert more than once.
550 (or inserted
08b1f8a1 551 (setcdr tail (cons (cons key definition) (cdr tail))))
113d28a8 552 (setq inserted t)))
4434d61b
RS
553 (setq tail (cdr tail)))))
554
a10cca6c 555(defun map-keymap-sorted (function keymap)
14694a59
RS
556 "Implement `map-keymap' with sorting.
557Don't call this function; it is for internal use only."
a10cca6c
SM
558 (let (list)
559 (map-keymap (lambda (a b) (push (cons a b) list))
560 keymap)
561 (setq list (sort list
562 (lambda (a b)
563 (setq a (car a) b (car b))
564 (if (integerp a)
565 (if (integerp b) (< a b)
566 t)
567 (if (integerp b) t
568 ;; string< also accepts symbols.
569 (string< a b))))))
570 (dolist (p list)
571 (funcall function (car p) (cdr p)))))
51fa3961 572
00f7c5ed
SM
573(defun keymap-canonicalize (map)
574 "Return an equivalent keymap, without inheritance."
575 (let ((bindings ())
c099a588
AS
576 (ranges ())
577 (prompt (keymap-prompt map)))
00f7c5ed
SM
578 (while (keymapp map)
579 (setq map (map-keymap-internal
580 (lambda (key item)
581 (if (consp key)
582 ;; Treat char-ranges specially.
583 (push (cons key item) ranges)
584 (push (cons key item) bindings)))
585 map)))
c099a588 586 (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt))
00f7c5ed
SM
587 (dolist (binding ranges)
588 ;; Treat char-ranges specially.
64981d1a 589 (define-key map (vector (car binding)) (cdr binding)))
00f7c5ed
SM
590 (dolist (binding (prog1 bindings (setq bindings ())))
591 (let* ((key (car binding))
592 (item (cdr binding))
593 (oldbind (assq key bindings)))
594 ;; Newer bindings override older.
595 (if oldbind (setq bindings (delq oldbind bindings)))
596 (when item ;nil bindings just hide older ones.
597 (push binding bindings))))
598 (nconc map bindings)))
599
8bed5e3d
RS
600(put 'keyboard-translate-table 'char-table-extra-slots 0)
601
9a5336ae
JB
602(defun keyboard-translate (from to)
603 "Translate character FROM to TO at a low level.
604This function creates a `keyboard-translate-table' if necessary
605and then modifies one entry in it."
8bed5e3d
RS
606 (or (char-table-p keyboard-translate-table)
607 (setq keyboard-translate-table
608 (make-char-table 'keyboard-translate-table nil)))
9a5336ae 609 (aset keyboard-translate-table from to))
9a5336ae 610\f
c4f484f2 611;;;; Key binding commands.
9a5336ae 612
c4f484f2
RS
613(defun global-set-key (key command)
614 "Give KEY a global binding as COMMAND.
615COMMAND is the command definition to use; usually it is
616a symbol naming an interactively-callable function.
617KEY is a key sequence; noninteractively, it is a string or vector
618of characters or event types, and non-ASCII characters with codes
619above 127 (such as ISO Latin-1) can be included if you use a vector.
9a5336ae 620
c4f484f2
RS
621Note that if KEY has a local binding in the current buffer,
622that local binding will continue to shadow any global binding
623that you make with this function."
624 (interactive "KSet key globally: \nCSet key %s to command: ")
625 (or (vectorp key) (stringp key)
626 (signal 'wrong-type-argument (list 'arrayp key)))
627 (define-key (current-global-map) key command))
9a5336ae 628
c4f484f2
RS
629(defun local-set-key (key command)
630 "Give KEY a local binding as COMMAND.
631COMMAND is the command definition to use; usually it is
632a symbol naming an interactively-callable function.
633KEY is a key sequence; noninteractively, it is a string or vector
634of characters or event types, and non-ASCII characters with codes
635above 127 (such as ISO Latin-1) can be included if you use a vector.
9a5336ae 636
c4f484f2
RS
637The binding goes in the current buffer's local map,
638which in most cases is shared with all other buffers in the same major mode."
639 (interactive "KSet key locally: \nCSet key %s locally to command: ")
640 (let ((map (current-local-map)))
641 (or map
642 (use-local-map (setq map (make-sparse-keymap))))
643 (or (vectorp key) (stringp key)
644 (signal 'wrong-type-argument (list 'arrayp key)))
645 (define-key map key command)))
9a5336ae 646
c4f484f2
RS
647(defun global-unset-key (key)
648 "Remove global binding of KEY.
649KEY is a string or vector representing a sequence of keystrokes."
650 (interactive "kUnset key globally: ")
651 (global-set-key key nil))
9a5336ae 652
c4f484f2
RS
653(defun local-unset-key (key)
654 "Remove local binding of KEY.
655KEY is a string or vector representing a sequence of keystrokes."
656 (interactive "kUnset key locally: ")
657 (if (current-local-map)
658 (local-set-key key nil))
659 nil)
660\f
661;;;; substitute-key-definition and its subroutines.
662
663(defvar key-substitution-in-progress nil
c8227332 664 "Used internally by `substitute-key-definition'.")
c4f484f2
RS
665
666(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
667 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
668In other words, OLDDEF is replaced with NEWDEF where ever it appears.
669Alternatively, if optional fourth argument OLDMAP is specified, we redefine
670in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP.
671
fda11e85
RS
672If you don't specify OLDMAP, you can usually get the same results
673in a cleaner way with command remapping, like this:
50d16788
JB
674 \(define-key KEYMAP [remap OLDDEF] NEWDEF)
675\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)"
c4f484f2
RS
676 ;; Don't document PREFIX in the doc string because we don't want to
677 ;; advertise it. It's meant for recursive calls only. Here's its
678 ;; meaning
679
680 ;; If optional argument PREFIX is specified, it should be a key
681 ;; prefix, a string. Redefined bindings will then be bound to the
682 ;; original key, with PREFIX added at the front.
683 (or prefix (setq prefix ""))
684 (let* ((scan (or oldmap keymap))
685 (prefix1 (vconcat prefix [nil]))
686 (key-substitution-in-progress
687 (cons scan key-substitution-in-progress)))
688 ;; Scan OLDMAP, finding each char or event-symbol that
689 ;; has any definition, and act on it with hack-key.
690 (map-keymap
691 (lambda (char defn)
692 (aset prefix1 (length prefix) char)
693 (substitute-key-definition-key defn olddef newdef prefix1 keymap))
694 scan)))
695
696(defun substitute-key-definition-key (defn olddef newdef prefix keymap)
697 (let (inner-def skipped menu-item)
698 ;; Find the actual command name within the binding.
699 (if (eq (car-safe defn) 'menu-item)
700 (setq menu-item defn defn (nth 2 defn))
701 ;; Skip past menu-prompt.
702 (while (stringp (car-safe defn))
703 (push (pop defn) skipped))
704 ;; Skip past cached key-equivalence data for menu items.
705 (if (consp (car-safe defn))
706 (setq defn (cdr defn))))
707 (if (or (eq defn olddef)
708 ;; Compare with equal if definition is a key sequence.
709 ;; That is useful for operating on function-key-map.
710 (and (or (stringp defn) (vectorp defn))
711 (equal defn olddef)))
712 (define-key keymap prefix
713 (if menu-item
714 (let ((copy (copy-sequence menu-item)))
715 (setcar (nthcdr 2 copy) newdef)
716 copy)
717 (nconc (nreverse skipped) newdef)))
718 ;; Look past a symbol that names a keymap.
719 (setq inner-def
cf25c647 720 (or (indirect-function defn t) defn))
c4f484f2
RS
721 ;; For nested keymaps, we use `inner-def' rather than `defn' so as to
722 ;; avoid autoloading a keymap. This is mostly done to preserve the
723 ;; original non-autoloading behavior of pre-map-keymap times.
724 (if (and (keymapp inner-def)
725 ;; Avoid recursively scanning
726 ;; where KEYMAP does not have a submap.
727 (let ((elt (lookup-key keymap prefix)))
728 (or (null elt) (natnump elt) (keymapp elt)))
729 ;; Avoid recursively rescanning keymap being scanned.
730 (not (memq inner-def key-substitution-in-progress)))
731 ;; If this one isn't being scanned already, scan it now.
732 (substitute-key-definition olddef newdef keymap inner-def prefix)))))
9a5336ae
JB
733
734\f
264ef586 735;;;; The global keymap tree.
9a5336ae 736
354f0faf
SM
737;; global-map, esc-map, and ctl-x-map have their values set up in
738;; keymap.c; we just give them docstrings here.
9a5336ae
JB
739
740(defvar global-map nil
741 "Default global keymap mapping Emacs keyboard input into commands.
742The value is a keymap which is usually (but not necessarily) Emacs's
743global map.")
744
745(defvar esc-map nil
746 "Default keymap for ESC (meta) commands.
747The normal global definition of the character ESC indirects to this keymap.")
748
749(defvar ctl-x-map nil
750 "Default keymap for C-x commands.
751The normal global definition of the character C-x indirects to this keymap.")
752
753(defvar ctl-x-4-map (make-sparse-keymap)
03eeb110 754 "Keymap for subcommands of C-x 4.")
059184dd 755(defalias 'ctl-x-4-prefix ctl-x-4-map)
9a5336ae
JB
756(define-key ctl-x-map "4" 'ctl-x-4-prefix)
757
758(defvar ctl-x-5-map (make-sparse-keymap)
759 "Keymap for frame commands.")
059184dd 760(defalias 'ctl-x-5-prefix ctl-x-5-map)
9a5336ae
JB
761(define-key ctl-x-map "5" 'ctl-x-5-prefix)
762
0f03054a 763\f
9a5336ae
JB
764;;;; Event manipulation functions.
765
03a74b84 766(defconst listify-key-sequence-1 (logior 128 ?\M-\C-@))
114137b8 767
cde6d7e3
RS
768(defun listify-key-sequence (key)
769 "Convert a key sequence to a list of events."
770 (if (vectorp key)
771 (append key nil)
772 (mapcar (function (lambda (c)
773 (if (> c 127)
114137b8 774 (logxor c listify-key-sequence-1)
cde6d7e3 775 c)))
d47f7515 776 key)))
cde6d7e3 777
53e5a4e8
RS
778(defsubst eventp (obj)
779 "True if the argument is an event object."
7a2937ce
SM
780 (or (and (integerp obj)
781 ;; Filter out integers too large to be events.
782 ;; M is the biggest modifier.
783 (zerop (logand obj (lognot (1- (lsh ?\M-\^@ 1)))))
327719ee 784 (characterp (event-basic-type obj)))
53e5a4e8
RS
785 (and (symbolp obj)
786 (get obj 'event-symbol-elements))
787 (and (consp obj)
788 (symbolp (car obj))
789 (get (car obj) 'event-symbol-elements))))
790
791(defun event-modifiers (event)
a3111ae4 792 "Return a list of symbols representing the modifier keys in event EVENT.
53e5a4e8 793The elements of the list may include `meta', `control',
32295976 794`shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
0e91dc92
LT
795and `down'.
796EVENT may be an event or an event type. If EVENT is a symbol
797that has never been used in an event that has been read as input
798in the current Emacs session, then this function can return nil,
799even when EVENT actually has modifiers."
53e5a4e8
RS
800 (let ((type event))
801 (if (listp type)
802 (setq type (car type)))
803 (if (symbolp type)
58da34c7
SM
804 ;; Don't read event-symbol-elements directly since we're not
805 ;; sure the symbol has already been parsed.
806 (cdr (internal-event-symbol-parse-modifiers type))
5572c97f
RS
807 (let ((list nil)
808 (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
809 ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
810 (if (not (zerop (logand type ?\M-\^@)))
9166dbf6 811 (push 'meta list))
5572c97f
RS
812 (if (or (not (zerop (logand type ?\C-\^@)))
813 (< char 32))
9166dbf6 814 (push 'control list))
5572c97f
RS
815 (if (or (not (zerop (logand type ?\S-\^@)))
816 (/= char (downcase char)))
9166dbf6 817 (push 'shift list))
da16e648 818 (or (zerop (logand type ?\H-\^@))
9166dbf6 819 (push 'hyper list))
da16e648 820 (or (zerop (logand type ?\s-\^@))
9166dbf6 821 (push 'super list))
da16e648 822 (or (zerop (logand type ?\A-\^@))
9166dbf6 823 (push 'alt list))
53e5a4e8
RS
824 list))))
825
d63de416 826(defun event-basic-type (event)
a3111ae4 827 "Return the basic type of the given event (all modifiers removed).
0e91dc92
LT
828The value is a printing character (not upper case) or a symbol.
829EVENT may be an event or an event type. If EVENT is a symbol
830that has never been used in an event that has been read as input
831in the current Emacs session, then this function may return nil."
2b0f4ba5
JB
832 (if (consp event)
833 (setq event (car event)))
d63de416
RS
834 (if (symbolp event)
835 (car (get event 'event-symbol-elements))
9aca2476
RS
836 (let* ((base (logand event (1- ?\A-\^@)))
837 (uncontrolled (if (< base 32) (logior base 64) base)))
838 ;; There are some numbers that are invalid characters and
839 ;; cause `downcase' to get an error.
840 (condition-case ()
841 (downcase uncontrolled)
842 (error uncontrolled)))))
d63de416 843
0f03054a
RS
844(defsubst mouse-movement-p (object)
845 "Return non-nil if OBJECT is a mouse movement event."
9166dbf6 846 (eq (car-safe object) 'mouse-movement))
0f03054a 847
5ad4f91c
SS
848(defun mouse-event-p (object)
849 "Return non-nil if OBJECT is a mouse click event."
850 ;; is this really correct? maybe remove mouse-movement?
851 (memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement)))
852
0f03054a
RS
853(defsubst event-start (event)
854 "Return the starting position of EVENT.
6b61353c 855If EVENT is a mouse or key press or a mouse click, this returns the location
0f03054a
RS
856of the event.
857If EVENT is a drag, this returns the drag's starting position.
858The return value is of the form
6b61353c
KH
859 (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
860 IMAGE (DX . DY) (WIDTH . HEIGHT))
0f03054a 861The `posn-' functions access elements of such lists."
5ef6a86d
SM
862 (if (consp event) (nth 1 event)
863 (list (selected-window) (point) '(0 . 0) 0)))
0f03054a
RS
864
865(defsubst event-end (event)
6b61353c
KH
866 "Return the ending location of EVENT.
867EVENT should be a click, drag, or key press event.
0f03054a
RS
868If EVENT is a click event, this function is the same as `event-start'.
869The return value is of the form
6b61353c
KH
870 (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
871 IMAGE (DX . DY) (WIDTH . HEIGHT))
0f03054a 872The `posn-' functions access elements of such lists."
5ef6a86d
SM
873 (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
874 (list (selected-window) (point) '(0 . 0) 0)))
0f03054a 875
32295976
RS
876(defsubst event-click-count (event)
877 "Return the multi-click count of EVENT, a click or drag event.
878The return value is a positive integer."
5ef6a86d 879 (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
c4f484f2
RS
880\f
881;;;; Extracting fields of the positions in an event.
32295976 882
0f03054a
RS
883(defsubst posn-window (position)
884 "Return the window in POSITION.
6b61353c
KH
885POSITION should be a list of the form returned by the `event-start'
886and `event-end' functions."
0f03054a
RS
887 (nth 0 position))
888
6b61353c
KH
889(defsubst posn-area (position)
890 "Return the window area recorded in POSITION, or nil for the text area.
891POSITION should be a list of the form returned by the `event-start'
892and `event-end' functions."
893 (let ((area (if (consp (nth 1 position))
894 (car (nth 1 position))
895 (nth 1 position))))
896 (and (symbolp area) area)))
897
0f03054a
RS
898(defsubst posn-point (position)
899 "Return the buffer location in POSITION.
6b61353c
KH
900POSITION should be a list of the form returned by the `event-start'
901and `event-end' functions."
902 (or (nth 5 position)
903 (if (consp (nth 1 position))
904 (car (nth 1 position))
905 (nth 1 position))))
906
907(defun posn-set-point (position)
908 "Move point to POSITION.
909Select the corresponding window as well."
c8227332
VJL
910 (if (not (windowp (posn-window position)))
911 (error "Position not in text area of window"))
912 (select-window (posn-window position))
913 (if (numberp (posn-point position))
914 (goto-char (posn-point position))))
0f03054a 915
e55c21be
RS
916(defsubst posn-x-y (position)
917 "Return the x and y coordinates in POSITION.
74194465
CY
918The return value has the form (X . Y), where X and Y are given in
919pixels. POSITION should be a list of the form returned by
920`event-start' and `event-end'."
0f03054a
RS
921 (nth 2 position))
922
aa360da1
GM
923(declare-function scroll-bar-scale "scroll-bar" (num-denom whole))
924
ed627e08 925(defun posn-col-row (position)
6b61353c
KH
926 "Return the nominal column and row in POSITION, measured in characters.
927The column and row values are approximations calculated from the x
928and y coordinates in POSITION and the frame's default character width
929and height.
ed627e08 930For a scroll-bar event, the result column is 0, and the row
6b61353c
KH
931corresponds to the vertical position of the click in the scroll bar.
932POSITION should be a list of the form returned by the `event-start'
933and `event-end' functions."
934 (let* ((pair (posn-x-y position))
935 (window (posn-window position))
936 (area (posn-area position)))
937 (cond
938 ((null window)
939 '(0 . 0))
940 ((eq area 'vertical-scroll-bar)
941 (cons 0 (scroll-bar-scale pair (1- (window-height window)))))
942 ((eq area 'horizontal-scroll-bar)
943 (cons (scroll-bar-scale pair (window-width window)) 0))
944 (t
945 (let* ((frame (if (framep window) window (window-frame window)))
7beba943
CY
946 ;; FIXME: This should take line-spacing properties on
947 ;; newlines into account.
948 (spacing (when (display-graphic-p frame)
949 (or (with-current-buffer (window-buffer window)
950 line-spacing)
951 (frame-parameter frame 'line-spacing)))))
952 (cond ((floatp spacing)
953 (setq spacing (truncate (* spacing
954 (frame-char-height frame)))))
955 ((null spacing)
956 (setq spacing 0)))
957 (cons (/ (car pair) (frame-char-width frame))
e68afd74 958 (- (/ (cdr pair) (+ (frame-char-height frame) spacing))
11aad4e9
EZ
959 (if (null (with-current-buffer (window-buffer window)
960 header-line-format))
961 0 1))))))))
6b61353c
KH
962
963(defun posn-actual-col-row (position)
964 "Return the actual column and row in POSITION, measured in characters.
965These are the actual row number in the window and character number in that row.
966Return nil if POSITION does not contain the actual position; in that case
967`posn-col-row' can be used to get approximate values.
968POSITION should be a list of the form returned by the `event-start'
969and `event-end' functions."
970 (nth 6 position))
e55c21be 971
0f03054a
RS
972(defsubst posn-timestamp (position)
973 "Return the timestamp of POSITION.
6b61353c
KH
974POSITION should be a list of the form returned by the `event-start'
975and `event-end' functions."
0f03054a 976 (nth 3 position))
9a5336ae 977
6b61353c 978(defsubst posn-string (position)
79a09c9c
KS
979 "Return the string object of POSITION.
980Value is a cons (STRING . STRING-POS), or nil if not a string.
6b61353c
KH
981POSITION should be a list of the form returned by the `event-start'
982and `event-end' functions."
983 (nth 4 position))
984
985(defsubst posn-image (position)
79a09c9c 986 "Return the image object of POSITION.
0c3f75f6 987Value is a list (image ...), or nil if not an image.
6b61353c
KH
988POSITION should be a list of the form returned by the `event-start'
989and `event-end' functions."
990 (nth 7 position))
991
992(defsubst posn-object (position)
993 "Return the object (image or string) of POSITION.
79a09c9c
KS
994Value is a list (image ...) for an image object, a cons cell
995\(STRING . STRING-POS) for a string object, and nil for a buffer position.
6b61353c
KH
996POSITION should be a list of the form returned by the `event-start'
997and `event-end' functions."
998 (or (posn-image position) (posn-string position)))
999
1000(defsubst posn-object-x-y (position)
1001 "Return the x and y coordinates relative to the object of POSITION.
74194465
CY
1002The return value has the form (DX . DY), where DX and DY are
1003given in pixels. POSITION should be a list of the form returned
1004by `event-start' and `event-end'."
6b61353c
KH
1005 (nth 8 position))
1006
1007(defsubst posn-object-width-height (position)
1008 "Return the pixel width and height of the object of POSITION.
74194465
CY
1009The return value has the form (WIDTH . HEIGHT). POSITION should
1010be a list of the form returned by `event-start' and `event-end'."
6b61353c
KH
1011 (nth 9 position))
1012
0f03054a 1013\f
9a5336ae
JB
1014;;;; Obsolescent names for functions.
1015
9d28c33e
SM
1016(define-obsolete-function-alias 'window-dot 'window-point "22.1")
1017(define-obsolete-function-alias 'set-window-dot 'set-window-point "22.1")
1018(define-obsolete-function-alias 'read-input 'read-string "22.1")
1019(define-obsolete-function-alias 'show-buffer 'set-window-buffer "22.1")
1020(define-obsolete-function-alias 'eval-current-buffer 'eval-buffer "22.1")
1021(define-obsolete-function-alias 'string-to-int 'string-to-number "22.1")
1022
9d28c33e
SM
1023(make-obsolete 'forward-point "use (+ (point) N) instead." "23.1")
1024
1025(defun insert-string (&rest args)
1026 "Mocklisp-compatibility insert function.
1027Like the function `insert' except that any argument that is a number
1028is converted into a string by expressing it in decimal."
1029 (dolist (el args)
1030 (insert (if (integerp el) (number-to-string el) el))))
1031(make-obsolete 'insert-string 'insert "22.1")
1032
1033(defun makehash (&optional test) (make-hash-table :test (or test 'eql)))
1034(make-obsolete 'makehash 'make-hash-table "22.1")
1035
1036;; These are used by VM and some old programs
1037(defalias 'focus-frame 'ignore "")
1038(make-obsolete 'focus-frame "it does nothing." "22.1")
1039(defalias 'unfocus-frame 'ignore "")
1040(make-obsolete 'unfocus-frame "it does nothing." "22.1")
1041(make-obsolete 'make-variable-frame-local
1042 "explicitly check for a frame-parameter instead." "22.2")
1043(make-obsolete 'interactive-p 'called-interactively-p "23.2")
f3a30a50 1044(set-advertised-calling-convention 'called-interactively-p '(kind) "23.1")
4fcc3d32 1045(set-advertised-calling-convention
f3a30a50
SM
1046 'all-completions '(string collection &optional predicate) "23.1")
1047(set-advertised-calling-convention 'unintern '(name obarray) "23.3")
9d28c33e
SM
1048\f
1049;;;; Obsolescence declarations for variables, and aliases.
1050
4e3b4528
SM
1051;; Special "default-FOO" variables which contain the default value of
1052;; the "FOO" variable are nasty. Their implementation is brittle, and
1053;; slows down several unrelated variable operations; furthermore, they
1054;; can lead to really odd behavior if you decide to make them
1055;; buffer-local.
1056
1057;; Not used at all in Emacs, last time I checked:
1058(make-obsolete-variable 'default-mode-line-format 'mode-line-format "23.2")
1059(make-obsolete-variable 'default-header-line-format 'header-line-format "23.2")
1060(make-obsolete-variable 'default-line-spacing 'line-spacing "23.2")
1061(make-obsolete-variable 'default-abbrev-mode 'abbrev-mode "23.2")
1062(make-obsolete-variable 'default-ctl-arrow 'ctl-arrow "23.2")
4e3b4528
SM
1063(make-obsolete-variable 'default-truncate-lines 'truncate-lines "23.2")
1064(make-obsolete-variable 'default-left-margin 'left-margin "23.2")
1065(make-obsolete-variable 'default-tab-width 'tab-width "23.2")
1066(make-obsolete-variable 'default-case-fold-search 'case-fold-search "23.2")
1067(make-obsolete-variable 'default-left-margin-width 'left-margin-width "23.2")
1068(make-obsolete-variable 'default-right-margin-width 'right-margin-width "23.2")
1069(make-obsolete-variable 'default-left-fringe-width 'left-fringe-width "23.2")
1070(make-obsolete-variable 'default-right-fringe-width 'right-fringe-width "23.2")
1071(make-obsolete-variable 'default-fringes-outside-margins 'fringes-outside-margins "23.2")
1072(make-obsolete-variable 'default-scroll-bar-width 'scroll-bar-width "23.2")
1073(make-obsolete-variable 'default-vertical-scroll-bar 'vertical-scroll-bar "23.2")
1074(make-obsolete-variable 'default-indicate-empty-lines 'indicate-empty-lines "23.2")
1075(make-obsolete-variable 'default-indicate-buffer-boundaries 'indicate-buffer-boundaries "23.2")
1076(make-obsolete-variable 'default-fringe-indicator-alist 'fringe-indicator-alist "23.2")
1077(make-obsolete-variable 'default-fringe-cursor-alist 'fringe-cursor-alist "23.2")
1078(make-obsolete-variable 'default-scroll-up-aggressively 'scroll-up-aggressively "23.2")
1079(make-obsolete-variable 'default-scroll-down-aggressively 'scroll-down-aggressively "23.2")
1080(make-obsolete-variable 'default-fill-column 'fill-column "23.2")
1081(make-obsolete-variable 'default-cursor-type 'cursor-type "23.2")
1082(make-obsolete-variable 'default-buffer-file-type 'buffer-file-type "23.2")
1083(make-obsolete-variable 'default-cursor-in-non-selected-windows 'cursor-in-non-selected-windows "23.2")
1084(make-obsolete-variable 'default-buffer-file-coding-system 'buffer-file-coding-system "23.2")
1085(make-obsolete-variable 'default-major-mode 'major-mode "23.2")
1086(make-obsolete-variable 'default-enable-multibyte-characters
1087 "use enable-multibyte-characters or set-buffer-multibyte instead" "23.2")
1088
50d4ba39 1089(make-obsolete-variable 'define-key-rebound-commands nil "23.2")
379ec02c
SM
1090(make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1")
1091(make-obsolete 'window-redisplay-end-trigger nil "23.1")
1092(make-obsolete 'set-window-redisplay-end-trigger nil "23.1")
1093
1094(make-obsolete 'process-filter-multibyte-p nil "23.1")
1095(make-obsolete 'set-process-filter-multibyte nil "23.1")
1096
c8227332
VJL
1097(make-obsolete-variable
1098 'mode-line-inverse-video
1099 "use the appropriate faces instead."
1100 "21.1")
1101(make-obsolete-variable
1102 'unread-command-char
1103 "use `unread-command-events' instead. That variable is a list of events
304bbefc 1104to reread, so it now uses nil to mean `no event', instead of -1."
c8227332 1105 "before 19.15")
bd292357 1106
8ee7e9db
LT
1107;; Lisp manual only updated in 22.1.
1108(define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro
c8227332 1109 "before 19.34")
8ee7e9db 1110
0ecd53f8 1111(defvaralias 'x-lost-selection-hooks 'x-lost-selection-functions)
c8227332
VJL
1112(make-obsolete-variable 'x-lost-selection-hooks
1113 'x-lost-selection-functions "22.1")
0ecd53f8 1114(defvaralias 'x-sent-selection-hooks 'x-sent-selection-functions)
c8227332
VJL
1115(make-obsolete-variable 'x-sent-selection-hooks
1116 'x-sent-selection-functions "22.1")
9e247d24 1117
b46957e2
EZ
1118;; This was introduced in 21.4 for pre-unicode unification. That
1119;; usage was rendered obsolete in 23.1 which uses Unicode internally.
1120;; Other uses are possible, so this variable is not _really_ obsolete,
1121;; but Stefan insists to mark it so.
1122(make-obsolete-variable 'translation-table-for-input nil "23.1")
1123
9e247d24 1124(defvaralias 'messages-buffer-max-lines 'message-log-max)
d293848d
GM
1125
1126;; These aliases exist in Emacs 19.34, and probably before, but were
1127;; only marked as obsolete in 23.1.
fb2bae29 1128;; The lisp manual (since at least Emacs 21) describes them as
d293848d
GM
1129;; existing "for compatibility with Emacs version 18".
1130(define-obsolete-variable-alias 'last-input-char 'last-input-event
1131 "at least 19.34")
1132(define-obsolete-variable-alias 'last-command-char 'last-command-event
1133 "at least 19.34")
1134
9a5336ae
JB
1135\f
1136;;;; Alternate names for functions - these are not being phased out.
1137
a18ff988
JB
1138(defalias 'send-string 'process-send-string)
1139(defalias 'send-region 'process-send-region)
059184dd
ER
1140(defalias 'string= 'string-equal)
1141(defalias 'string< 'string-lessp)
1142(defalias 'move-marker 'set-marker)
059184dd
ER
1143(defalias 'rplaca 'setcar)
1144(defalias 'rplacd 'setcdr)
eb8c3be9 1145(defalias 'beep 'ding) ;preserve lingual purity
059184dd
ER
1146(defalias 'indent-to-column 'indent-to)
1147(defalias 'backward-delete-char 'delete-backward-char)
1148(defalias 'search-forward-regexp (symbol-function 're-search-forward))
1149(defalias 'search-backward-regexp (symbol-function 're-search-backward))
1150(defalias 'int-to-string 'number-to-string)
024ae2c6 1151(defalias 'store-match-data 'set-match-data)
e6979067 1152(defalias 'chmod 'set-file-modes)
53374291 1153(defalias 'mkdir 'make-directory)
d6c22d46 1154;; These are the XEmacs names:
475fb2fb
KH
1155(defalias 'point-at-eol 'line-end-position)
1156(defalias 'point-at-bol 'line-beginning-position)
37f6661a 1157
c4f484f2
RS
1158(defalias 'user-original-login-name 'user-login-name)
1159
be9b65ac 1160\f
9a5336ae 1161;;;; Hook manipulation functions.
be9b65ac 1162
0e4d378b 1163(defun add-hook (hook function &optional append local)
32295976
RS
1164 "Add to the value of HOOK the function FUNCTION.
1165FUNCTION is not added if already present.
1166FUNCTION is added (if necessary) at the beginning of the hook list
1167unless the optional argument APPEND is non-nil, in which case
1168FUNCTION is added at the end.
1169
0e4d378b
RS
1170The optional fourth argument, LOCAL, if non-nil, says to modify
1171the hook's buffer-local value rather than its default value.
61a3d8c4
RS
1172This makes the hook buffer-local if needed, and it makes t a member
1173of the buffer-local value. That acts as a flag to run the hook
1174functions in the default value as well as in the local value.
0e4d378b 1175
32295976
RS
1176HOOK should be a symbol, and FUNCTION may be any valid function. If
1177HOOK is void, it is first set to nil. If HOOK's value is a single
aa09b5ca 1178function, it is changed to a list of functions."
be9b65ac 1179 (or (boundp hook) (set hook nil))
0e4d378b 1180 (or (default-boundp hook) (set-default hook nil))
08b1f8a1
GM
1181 (if local (unless (local-variable-if-set-p hook)
1182 (set (make-local-variable hook) (list t)))
8947a5e2
SM
1183 ;; Detect the case where make-local-variable was used on a hook
1184 ;; and do what we used to do.
1185 (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
1186 (setq local t)))
1187 (let ((hook-value (if local (symbol-value hook) (default-value hook))))
1188 ;; If the hook value is a single function, turn it into a list.
1189 (when (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
2248c40d 1190 (setq hook-value (list hook-value)))
8947a5e2
SM
1191 ;; Do the actual addition if necessary
1192 (unless (member function hook-value)
ff917d63
DN
1193 (when (stringp function)
1194 (setq function (purecopy function)))
8947a5e2
SM
1195 (setq hook-value
1196 (if append
1197 (append hook-value (list function))
1198 (cons function hook-value))))
1199 ;; Set the actual variable
35310461
RS
1200 (if local
1201 (progn
1202 ;; If HOOK isn't a permanent local,
1203 ;; but FUNCTION wants to survive a change of modes,
1204 ;; mark HOOK as partially permanent.
1205 (and (symbolp function)
1206 (get function 'permanent-local-hook)
1207 (not (get hook 'permanent-local))
1208 (put hook 'permanent-local 'permanent-local-hook))
1209 (set hook hook-value))
1210 (set-default hook hook-value))))
0e4d378b
RS
1211
1212(defun remove-hook (hook function &optional local)
24980d16
RS
1213 "Remove from the value of HOOK the function FUNCTION.
1214HOOK should be a symbol, and FUNCTION may be any valid function. If
1215FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
0e4d378b
RS
1216list of hooks to run in HOOK, then nothing is done. See `add-hook'.
1217
1218The optional third argument, LOCAL, if non-nil, says to modify
6b61353c 1219the hook's buffer-local value rather than its default value."
8947a5e2
SM
1220 (or (boundp hook) (set hook nil))
1221 (or (default-boundp hook) (set-default hook nil))
6b61353c
KH
1222 ;; Do nothing if LOCAL is t but this hook has no local binding.
1223 (unless (and local (not (local-variable-p hook)))
8947a5e2
SM
1224 ;; Detect the case where make-local-variable was used on a hook
1225 ;; and do what we used to do.
6b61353c
KH
1226 (when (and (local-variable-p hook)
1227 (not (and (consp (symbol-value hook))
1228 (memq t (symbol-value hook)))))
1229 (setq local t))
1230 (let ((hook-value (if local (symbol-value hook) (default-value hook))))
1231 ;; Remove the function, for both the list and the non-list cases.
1232 (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
1233 (if (equal hook-value function) (setq hook-value nil))
1234 (setq hook-value (delete function (copy-sequence hook-value))))
1235 ;; If the function is on the global hook, we need to shadow it locally
1236 ;;(when (and local (member function (default-value hook))
1237 ;; (not (member (cons 'not function) hook-value)))
1238 ;; (push (cons 'not function) hook-value))
1239 ;; Set the actual variable
1240 (if (not local)
1241 (set-default hook hook-value)
1242 (if (equal hook-value '(t))
1243 (kill-local-variable hook)
1244 (set hook hook-value))))))
6e3af630 1245
62e197b1 1246(defun add-to-list (list-var element &optional append compare-fn)
4072ef25 1247 "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
62e197b1
RS
1248The test for presence of ELEMENT is done with `equal',
1249or with COMPARE-FN if that's non-nil.
c8bfa689
MB
1250If ELEMENT is added, it is added at the beginning of the list,
1251unless the optional argument APPEND is non-nil, in which case
1252ELEMENT is added at the end.
508bcbca 1253
daebae3d
PJ
1254The return value is the new value of LIST-VAR.
1255
8851c1f0
RS
1256If you want to use `add-to-list' on a variable that is not defined
1257until a certain package is loaded, you should put the call to `add-to-list'
1258into a hook function that will be run only after loading the package.
1259`eval-after-load' provides one way to do this. In some cases
1260other hooks, such as major mode hooks, can do the job."
fb1a5d8a 1261 (if (cond
78bdfbf3 1262 ((null compare-fn)
62e197b1 1263 (member element (symbol-value list-var)))
fb1a5d8a
KS
1264 ((eq compare-fn 'eq)
1265 (memq element (symbol-value list-var)))
1266 ((eq compare-fn 'eql)
1267 (memql element (symbol-value list-var)))
78bdfbf3 1268 (t
2d1dd54d
DK
1269 (let ((lst (symbol-value list-var)))
1270 (while (and lst
1271 (not (funcall compare-fn element (car lst))))
1272 (setq lst (cdr lst)))
1273 lst)))
15171a06 1274 (symbol-value list-var)
c8bfa689
MB
1275 (set list-var
1276 (if append
1277 (append (symbol-value list-var) (list element))
1278 (cons element (symbol-value list-var))))))
448a0170 1279
cbbd0b5a
KS
1280
1281(defun add-to-ordered-list (list-var element &optional order)
4072ef25 1282 "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
ef1eef06 1283The test for presence of ELEMENT is done with `eq'.
cbbd0b5a
KS
1284
1285The resulting list is reordered so that the elements are in the
ef1eef06
KS
1286order given by each element's numeric list order. Elements
1287without a numeric list order are placed at the end of the list.
cbbd0b5a 1288
4072ef25
LT
1289If the third optional argument ORDER is a number (integer or
1290float), set the element's list order to the given value. If
1291ORDER is nil or omitted, do not change the numeric order of
1292ELEMENT. If ORDER has any other value, remove the numeric order
1293of ELEMENT if it has one.
8da6c2f8 1294
219fd6cf 1295The list order for each element is stored in LIST-VAR's
8da6c2f8 1296`list-order' property.
cbbd0b5a
KS
1297
1298The return value is the new value of LIST-VAR."
219fd6cf
SM
1299 (let ((ordering (get list-var 'list-order)))
1300 (unless ordering
1301 (put list-var 'list-order
1302 (setq ordering (make-hash-table :weakness 'key :test 'eq))))
8da6c2f8 1303 (when order
ef1eef06
KS
1304 (puthash element (and (numberp order) order) ordering))
1305 (unless (memq element (symbol-value list-var))
1306 (set list-var (cons element (symbol-value list-var))))
8da6c2f8
KS
1307 (set list-var (sort (symbol-value list-var)
1308 (lambda (a b)
219fd6cf
SM
1309 (let ((oa (gethash a ordering))
1310 (ob (gethash b ordering)))
ef1eef06
KS
1311 (if (and oa ob)
1312 (< oa ob)
1313 oa)))))))
6b04bd6e 1314
d7494911 1315(defun add-to-history (history-var newelt &optional maxelt keep-all)
6b04bd6e
KS
1316 "Add NEWELT to the history list stored in the variable HISTORY-VAR.
1317Return the new history list.
1318If MAXELT is non-nil, it specifies the maximum length of the history.
1319Otherwise, the maximum history length is the value of the `history-length'
1320property on symbol HISTORY-VAR, if set, or the value of the `history-length'
1321variable.
d7494911
KS
1322Remove duplicates of NEWELT if `history-delete-duplicates' is non-nil.
1323If optional fourth arg KEEP-ALL is non-nil, add NEWELT to history even
1324if it is empty or a duplicate."
6b04bd6e
KS
1325 (unless maxelt
1326 (setq maxelt (or (get history-var 'history-length)
1327 history-length)))
1328 (let ((history (symbol-value history-var))
1329 tail)
d7494911
KS
1330 (when (and (listp history)
1331 (or keep-all
1332 (not (stringp newelt))
1333 (> (length newelt) 0))
1334 (or keep-all
1335 (not (equal (car history) newelt))))
1336 (if history-delete-duplicates
1337 (delete newelt history))
1338 (setq history (cons newelt history))
1339 (when (integerp maxelt)
1340 (if (= 0 maxelt)
1341 (setq history nil)
1342 (setq tail (nthcdr (1- maxelt) history))
1343 (when (consp tail)
1344 (setcdr tail nil)))))
6b04bd6e
KS
1345 (set history-var history)))
1346
c4f484f2
RS
1347\f
1348;;;; Mode hooks.
1349
1350(defvar delay-mode-hooks nil
1351 "If non-nil, `run-mode-hooks' should delay running the hooks.")
1352(defvar delayed-mode-hooks nil
1353 "List of delayed mode hooks waiting to be run.")
1354(make-variable-buffer-local 'delayed-mode-hooks)
1355(put 'delay-mode-hooks 'permanent-local t)
cbbd0b5a 1356
c4f484f2
RS
1357(defvar after-change-major-mode-hook nil
1358 "Normal hook run at the very end of major mode functions.")
1359
1360(defun run-mode-hooks (&rest hooks)
1361 "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
5612fd08
GM
1362Execution is delayed if the variable `delay-mode-hooks' is non-nil.
1363Otherwise, runs the mode hooks and then `after-change-major-mode-hook'.
337a64d1
SM
1364Major mode functions should use this instead of `run-hooks' when running their
1365FOO-mode-hook."
c4f484f2
RS
1366 (if delay-mode-hooks
1367 ;; Delaying case.
1368 (dolist (hook hooks)
1369 (push hook delayed-mode-hooks))
1370 ;; Normal case, just run the hook as before plus any delayed hooks.
1371 (setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
1372 (setq delayed-mode-hooks nil)
1373 (apply 'run-hooks hooks)
1374 (run-hooks 'after-change-major-mode-hook)))
1375
1376(defmacro delay-mode-hooks (&rest body)
1377 "Execute BODY, but delay any `run-mode-hooks'.
1378These hooks will be executed by the first following call to
1379`run-mode-hooks' that occurs outside any `delayed-mode-hooks' form.
1380Only affects hooks run in the current buffer."
1381 (declare (debug t) (indent 0))
1382 `(progn
1383 (make-local-variable 'delay-mode-hooks)
1384 (let ((delay-mode-hooks t))
1385 ,@body)))
1386
1387;; PUBLIC: find if the current mode derives from another.
1388
1389(defun derived-mode-p (&rest modes)
1390 "Non-nil if the current major mode is derived from one of MODES.
1391Uses the `derived-mode-parent' property of the symbol to trace backwards."
1392 (let ((parent major-mode))
1393 (while (and (not (memq parent modes))
1394 (setq parent (get parent 'derived-mode-parent))))
1395 parent))
1396\f
1397;;;; Minor modes.
1398
1399;; If a minor mode is not defined with define-minor-mode,
1400;; add it here explicitly.
1401;; isearch-mode is deliberately excluded, since you should
1402;; not call it yourself.
1403(defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode
1404 overwrite-mode view-mode
1405 hs-minor-mode)
1406 "List of all minor mode functions.")
1407
1408(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
1409 "Register a new minor mode.
1410
1411This is an XEmacs-compatibility function. Use `define-minor-mode' instead.
1412
1413TOGGLE is a symbol which is the name of a buffer-local variable that
1414is toggled on or off to say whether the minor mode is active or not.
1415
1416NAME specifies what will appear in the mode line when the minor mode
1417is active. NAME should be either a string starting with a space, or a
1418symbol whose value is such a string.
1419
1420Optional KEYMAP is the keymap for the minor mode that will be added
1421to `minor-mode-map-alist'.
1422
1423Optional AFTER specifies that TOGGLE should be added after AFTER
1424in `minor-mode-alist'.
1425
1426Optional TOGGLE-FUN is an interactive function to toggle the mode.
1427It defaults to (and should by convention be) TOGGLE.
1428
1429If TOGGLE has a non-nil `:included' property, an entry for the mode is
1430included in the mode-line minor mode menu.
1431If TOGGLE has a `:menu-tag', that is used for the menu item's label."
1432 (unless (memq toggle minor-mode-list)
1433 (push toggle minor-mode-list))
1434
1435 (unless toggle-fun (setq toggle-fun toggle))
1436 (unless (eq toggle-fun toggle)
1437 (put toggle :minor-mode-function toggle-fun))
1438 ;; Add the name to the minor-mode-alist.
1439 (when name
1440 (let ((existing (assq toggle minor-mode-alist)))
1441 (if existing
1442 (setcdr existing (list name))
1443 (let ((tail minor-mode-alist) found)
1444 (while (and tail (not found))
1445 (if (eq after (caar tail))
1446 (setq found tail)
1447 (setq tail (cdr tail))))
1448 (if found
1449 (let ((rest (cdr found)))
1450 (setcdr found nil)
1451 (nconc found (list (list toggle name)) rest))
365f8d85 1452 (push (list toggle name) minor-mode-alist))))))
c4f484f2
RS
1453 ;; Add the toggle to the minor-modes menu if requested.
1454 (when (get toggle :included)
1455 (define-key mode-line-mode-menu
1456 (vector toggle)
1457 (list 'menu-item
1458 (concat
1459 (or (get toggle :menu-tag)
1460 (if (stringp name) name (symbol-name toggle)))
1461 (let ((mode-name (if (symbolp name) (symbol-value name))))
1462 (if (and (stringp mode-name) (string-match "[^ ]+" mode-name))
1463 (concat " (" (match-string 0 mode-name) ")"))))
1464 toggle-fun
1465 :button (cons :toggle toggle))))
cbbd0b5a 1466
c4f484f2
RS
1467 ;; Add the map to the minor-mode-map-alist.
1468 (when keymap
1469 (let ((existing (assq toggle minor-mode-map-alist)))
1470 (if existing
1471 (setcdr existing keymap)
1472 (let ((tail minor-mode-map-alist) found)
1473 (while (and tail (not found))
1474 (if (eq after (caar tail))
1475 (setq found tail)
1476 (setq tail (cdr tail))))
1477 (if found
1478 (let ((rest (cdr found)))
1479 (setcdr found nil)
1480 (nconc found (list (cons toggle keymap)) rest))
365f8d85 1481 (push (cons toggle keymap) minor-mode-map-alist)))))))
448a0170
MB
1482\f
1483;;; Load history
1484
9e247d24 1485(defun symbol-file (symbol &optional type)
37fda77e
MR
1486 "Return the name of the file that defined SYMBOL.
1487The value is normally an absolute file name. It can also be nil,
1488if the definition is not associated with any file. If SYMBOL
1489specifies an autoloaded function, the value can be a relative
1490file name without extension.
1491
1492If TYPE is nil, then any kind of definition is acceptable. If
1493TYPE is `defun', `defvar', or `defface', that specifies function
1494definition, variable definition, or face definition only."
9e247d24
RS
1495 (if (and (or (null type) (eq type 'defun))
1496 (symbolp symbol) (fboundp symbol)
1497 (eq 'autoload (car-safe (symbol-function symbol))))
1498 (nth 1 (symbol-function symbol))
e9f13a95 1499 (let ((files load-history)
cb21744e 1500 file)
e9f13a95 1501 (while files
9e247d24
RS
1502 (if (if type
1503 (if (eq type 'defvar)
1504 ;; Variables are present just as their names.
1505 (member symbol (cdr (car files)))
1506 ;; Other types are represented as (TYPE . NAME).
1507 (member (cons type symbol) (cdr (car files))))
1508 ;; We accept all types, so look for variable def
1509 ;; and then for any other kind.
1510 (or (member symbol (cdr (car files)))
1511 (rassq symbol (cdr (car files)))))
e9f13a95
SM
1512 (setq file (car (car files)) files nil))
1513 (setq files (cdr files)))
1514 file)))
448a0170 1515
059a552c
RF
1516(defun locate-library (library &optional nosuffix path interactive-call)
1517 "Show the precise file name of Emacs library LIBRARY.
c9ae6ddd
EZ
1518LIBRARY should be a relative file name of the library, a string.
1519It can omit the suffix (a.k.a. file-name extension) if NOSUFFIX is
1520nil (which is the default, see below).
059a552c
RF
1521This command searches the directories in `load-path' like `\\[load-library]'
1522to find the file that `\\[load-library] RET LIBRARY RET' would load.
1523Optional second arg NOSUFFIX non-nil means don't add suffixes `load-suffixes'
1524to the specified name LIBRARY.
1525
1526If the optional third arg PATH is specified, that list of directories
1527is used instead of `load-path'.
1528
3ac9d254 1529When called from a program, the file name is normally returned as a
059a552c
RF
1530string. When run interactively, the argument INTERACTIVE-CALL is t,
1531and the file name is displayed in the echo area."
1532 (interactive (list (completing-read "Locate library: "
6a021917
SM
1533 (apply-partially
1534 'locate-file-completion-table
1535 load-path (get-load-suffixes)))
059a552c
RF
1536 nil nil
1537 t))
1538 (let ((file (locate-file library
1539 (or path load-path)
667b73dc
LT
1540 (append (unless nosuffix (get-load-suffixes))
1541 load-file-rep-suffixes))))
059a552c
RF
1542 (if interactive-call
1543 (if file
1544 (message "Library is file %s" (abbreviate-file-name file))
1545 (message "No library %s in search path" library)))
1546 file))
1547
be9b65ac 1548\f
adbe2d11
RS
1549;;;; Specifying things to do later.
1550
33d74677 1551(defun load-history-regexp (file)
0988217a
RS
1552 "Form a regexp to find FILE in `load-history'.
1553FILE, a string, is described in the function `eval-after-load'."
33d74677
AM
1554 (if (file-name-absolute-p file)
1555 (setq file (file-truename file)))
0988217a 1556 (concat (if (file-name-absolute-p file) "\\`" "\\(\\`\\|/\\)")
33d74677
AM
1557 (regexp-quote file)
1558 (if (file-name-extension file)
1559 ""
1560 ;; Note: regexp-opt can't be used here, since we need to call
1561 ;; this before Emacs has been fully started. 2006-05-21
1562 (concat "\\(" (mapconcat 'regexp-quote load-suffixes "\\|") "\\)?"))
1563 "\\(" (mapconcat 'regexp-quote jka-compr-load-suffixes "\\|")
1564 "\\)?\\'"))
1565
1566(defun load-history-filename-element (file-regexp)
0988217a 1567 "Get the first elt of `load-history' whose car matches FILE-REGEXP.
33d74677
AM
1568Return nil if there isn't one."
1569 (let* ((loads load-history)
1570 (load-elt (and loads (car loads))))
1571 (save-match-data
1572 (while (and loads
1573 (or (null (car load-elt))
1574 (not (string-match file-regexp (car load-elt)))))
1575 (setq loads (cdr loads)
1576 load-elt (and loads (car loads)))))
1577 load-elt))
1578
f291fe60 1579(put 'eval-after-load 'lisp-indent-function 1)
9a5336ae
JB
1580(defun eval-after-load (file form)
1581 "Arrange that, if FILE is ever loaded, FORM will be run at that time.
90914938 1582If FILE is already loaded, evaluate FORM right now.
33d74677
AM
1583
1584If a matching file is loaded again, FORM will be evaluated again.
1585
1586If FILE is a string, it may be either an absolute or a relative file
1587name, and may have an extension \(e.g. \".el\") or may lack one, and
1588additionally may or may not have an extension denoting a compressed
1589format \(e.g. \".gz\").
1590
0988217a
RS
1591When FILE is absolute, this first converts it to a true name by chasing
1592symbolic links. Only a file of this name \(see next paragraph regarding
33d74677
AM
1593extensions) will trigger the evaluation of FORM. When FILE is relative,
1594a file whose absolute true name ends in FILE will trigger evaluation.
1595
1596When FILE lacks an extension, a file name with any extension will trigger
1597evaluation. Otherwise, its extension must match FILE's. A further
1598extension for a compressed format \(e.g. \".gz\") on FILE will not affect
1599this name matching.
1600
1601Alternatively, FILE can be a feature (i.e. a symbol), in which case FORM
f176290e
GM
1602is evaluated whenever that feature is `provide'd. Note that although
1603provide statements are usually at the end of files, this is not always
1604the case (e.g., sometimes they are at the start to avoid a recursive
1605load error). If your FORM should not be evaluated until the code in
1606FILE has been, do not use the symbol form for FILE in such cases.
33d74677
AM
1607
1608Usually FILE is just a library name like \"font-lock\" or a feature name
1609like 'font-lock.
1610
1611This function makes or adds to an entry on `after-load-alist'."
1612 ;; Add this FORM into after-load-alist (regardless of whether we'll be
1613 ;; evaluating it now).
1614 (let* ((regexp-or-feature
ff917d63 1615 (if (stringp file) (setq file (purecopy (load-history-regexp file))) file))
33d74677
AM
1616 (elt (assoc regexp-or-feature after-load-alist)))
1617 (unless elt
1618 (setq elt (list regexp-or-feature))
1619 (push elt after-load-alist))
1620 ;; Add FORM to the element unless it's already there.
a2d7836f 1621 (unless (member form (cdr elt))
ff917d63 1622 (nconc elt (purecopy (list form))))
33d74677
AM
1623
1624 ;; Is there an already loaded file whose name (or `provide' name)
1625 ;; matches FILE?
1626 (if (if (stringp file)
1627 (load-history-filename-element regexp-or-feature)
1628 (featurep file))
1629 (eval form))))
1630
838ff458
SM
1631(defvar after-load-functions nil
1632 "Special hook run after loading a file.
1633Each function there is called with a single argument, the absolute
1634name of the file just loaded.")
1635
33d74677
AM
1636(defun do-after-load-evaluation (abs-file)
1637 "Evaluate all `eval-after-load' forms, if any, for ABS-FILE.
5766c380
SM
1638ABS-FILE, a string, should be the absolute true name of a file just loaded.
1639This function is called directly from the C code."
1640 ;; Run the relevant eval-after-load forms.
060c08b5
JB
1641 (mapc #'(lambda (a-l-element)
1642 (when (and (stringp (car a-l-element))
1643 (string-match-p (car a-l-element) abs-file))
1644 ;; discard the file name regexp
1645 (mapc #'eval (cdr a-l-element))))
5766c380
SM
1646 after-load-alist)
1647 ;; Complain when the user uses obsolete files.
838ff458 1648 (when (string-match-p "/obsolete/[^/]*\\'" abs-file)
5766c380
SM
1649 (run-with-timer 0 nil
1650 (lambda (file)
1651 (message "Package %s is obsolete!"
1652 (substring file 0
1653 (string-match "\\.elc?\\>" file))))
838ff458
SM
1654 (file-name-nondirectory abs-file)))
1655 ;; Finally, run any other hook.
1656 (run-hook-with-args 'after-load-functions abs-file))
9a5336ae
JB
1657
1658(defun eval-next-after-load (file)
1659 "Read the following input sexp, and run it whenever FILE is loaded.
1660This makes or adds to an entry on `after-load-alist'.
1661FILE should be the name of a library, with no directory name."
1662 (eval-after-load file (read)))
354f0faf 1663(make-obsolete 'eval-next-after-load `eval-after-load "23.2")
7aaacaff 1664\f
c4f484f2
RS
1665;;;; Process stuff.
1666
d43c8d03
GM
1667(defun process-lines (program &rest args)
1668 "Execute PROGRAM with ARGS, returning its output as a list of lines.
1669Signal an error if the program returns with a non-zero exit status."
1670 (with-temp-buffer
1671 (let ((status (apply 'call-process program nil (current-buffer) nil args)))
1672 (unless (eq status 0)
1673 (error "%s exited with status %s" program status))
1674 (goto-char (point-min))
1675 (let (lines)
1676 (while (not (eobp))
1677 (setq lines (cons (buffer-substring-no-properties
1678 (line-beginning-position)
1679 (line-end-position))
1680 lines))
1681 (forward-line 1))
1682 (nreverse lines)))))
1683
c4f484f2 1684;; open-network-stream is a wrapper around make-network-process.
7aaacaff 1685
149d2fd3
KS
1686(when (featurep 'make-network-process)
1687 (defun open-network-stream (name buffer host service)
c8227332 1688 "Open a TCP connection for a service to a host.
7aaacaff
RS
1689Returns a subprocess-object to represent the connection.
1690Input and output work as for subprocesses; `delete-process' closes it.
a478f3e1 1691
00b9254c
GM
1692NAME is the name for the process. It is modified if necessary to make
1693 it unique.
6ec6d6f4
GM
1694BUFFER is the buffer (or buffer name) to associate with the
1695 process. Process output goes at end of that buffer. BUFFER may
1696 be nil, meaning that this process is not associated with any buffer.
1697HOST is the name or IP address of the host to connect to.
1698SERVICE is the name of the service desired, or an integer specifying
1699 a port number to connect to.
1700
1701This is a wrapper around `make-network-process', and only offers a
1702subset of its functionality."
c8227332
VJL
1703 (make-network-process :name name :buffer buffer
1704 :host host :service service)))
7aaacaff
RS
1705
1706;; compatibility
1707
c8227332
VJL
1708(make-obsolete
1709 'process-kill-without-query
1710 "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
1711 "22.1")
7aaacaff
RS
1712(defun process-kill-without-query (process &optional flag)
1713 "Say no query needed if PROCESS is running when Emacs is exited.
1714Optional second argument if non-nil says to require a query.
a478f3e1 1715Value is t if a query was formerly required."
7aaacaff
RS
1716 (let ((old (process-query-on-exit-flag process)))
1717 (set-process-query-on-exit-flag process nil)
1718 old))
9a5336ae 1719
d842b103
JL
1720(defun process-kill-buffer-query-function ()
1721 "Ask before killing a buffer that has a running process."
1722 (let ((process (get-buffer-process (current-buffer))))
1723 (or (not process)
1724 (not (memq (process-status process) '(run stop open listen)))
1725 (not (process-query-on-exit-flag process))
1726 (yes-or-no-p "Buffer has a running process; kill it? "))))
1727
1728(add-hook 'kill-buffer-query-functions 'process-kill-buffer-query-function)
1729
34368d12
KS
1730;; process plist management
1731
1732(defun process-get (process propname)
1733 "Return the value of PROCESS' PROPNAME property.
1734This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'."
1735 (plist-get (process-plist process) propname))
1736
1737(defun process-put (process propname value)
1738 "Change PROCESS' PROPNAME property to VALUE.
1739It can be retrieved with `(process-get PROCESS PROPNAME)'."
f1180544 1740 (set-process-plist process
34368d12
KS
1741 (plist-put (process-plist process) propname value)))
1742
9a5336ae
JB
1743\f
1744;;;; Input and display facilities.
1745
77a5664f 1746(defvar read-quoted-char-radix 8
1ba764de 1747 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
77a5664f
RS
1748Legitimate radix values are 8, 10 and 16.")
1749
1750(custom-declare-variable-early
264ef586 1751 'read-quoted-char-radix 8
77a5664f 1752 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
1ba764de 1753Legitimate radix values are 8, 10 and 16."
c8227332
VJL
1754 :type '(choice (const 8) (const 10) (const 16))
1755 :group 'editing-basics)
1ba764de 1756
03a74b84
SM
1757(defconst read-key-empty-map (make-sparse-keymap))
1758
79bd5ba1 1759(defvar read-key-delay 0.01) ;Fast enough for 100Hz repeat rate, hopefully.
03a74b84
SM
1760
1761(defun read-key (&optional prompt)
1762 "Read a key from the keyboard.
1763Contrary to `read-event' this will not return a raw event but instead will
1764obey the input decoding and translations usually done by `read-key-sequence'.
1765So escape sequences and keyboard encoding are taken into account.
1766When there's an ambiguity because the key looks like the prefix of
1767some sort of escape sequence, the ambiguity is resolved via `read-key-delay'."
1768 (let ((overriding-terminal-local-map read-key-empty-map)
1769 (overriding-local-map nil)
3ff78624 1770 (echo-keystrokes 0)
03a74b84
SM
1771 (old-global-map (current-global-map))
1772 (timer (run-with-idle-timer
1773 ;; Wait long enough that Emacs has the time to receive and
1774 ;; process all the raw events associated with the single-key.
1775 ;; But don't wait too long, or the user may find the delay
1776 ;; annoying (or keep hitting more keys which may then get
1777 ;; lost or misinterpreted).
1778 ;; This is only relevant for keys which Emacs perceives as
1779 ;; "prefixes", such as C-x (because of the C-x 8 map in
1780 ;; key-translate-table and the C-x @ map in function-key-map)
1781 ;; or ESC (because of terminal escape sequences in
1782 ;; input-decode-map).
1783 read-key-delay t
1784 (lambda ()
1785 (let ((keys (this-command-keys-vector)))
1786 (unless (zerop (length keys))
1787 ;; `keys' is non-empty, so the user has hit at least
1788 ;; one key; there's no point waiting any longer, even
1789 ;; though read-key-sequence thinks we should wait
1790 ;; for more input to decide how to interpret the
1791 ;; current input.
1792 (throw 'read-key keys)))))))
1793 (unwind-protect
1794 (progn
186e86db
SM
1795 (use-global-map
1796 (let ((map (make-sparse-keymap)))
1797 ;; Don't hide the menu-bar and tool-bar entries.
1798 (define-key map [menu-bar] (lookup-key global-map [menu-bar]))
1799 (define-key map [tool-bar] (lookup-key global-map [tool-bar]))
1800 map))
79bd5ba1 1801 (aref (catch 'read-key (read-key-sequence-vector prompt nil t)) 0))
03a74b84
SM
1802 (cancel-timer timer)
1803 (use-global-map old-global-map))))
1804
9a5336ae 1805(defun read-quoted-char (&optional prompt)
2444730b
RS
1806 "Like `read-char', but do not allow quitting.
1807Also, if the first character read is an octal digit,
1808we read any number of octal digits and return the
569b03f2 1809specified character code. Any nondigit terminates the sequence.
1ba764de 1810If the terminator is RET, it is discarded;
2444730b
RS
1811any other terminator is used itself as input.
1812
569b03f2
RS
1813The optional argument PROMPT specifies a string to use to prompt the user.
1814The variable `read-quoted-char-radix' controls which radix to use
1815for numeric input."
c83256a0 1816 (let ((message-log-max nil) done (first t) (code 0) char translated)
2444730b
RS
1817 (while (not done)
1818 (let ((inhibit-quit first)
42e636f0
KH
1819 ;; Don't let C-h get the help message--only help function keys.
1820 (help-char nil)
1821 (help-form
1822 "Type the special character you want to use,
2444730b 1823or the octal character code.
1ba764de 1824RET terminates the character code and is discarded;
2444730b 1825any other non-digit terminates the character code and is then used as input."))
3f0161d0 1826 (setq char (read-event (and prompt (format "%s-" prompt)) t))
9a5336ae 1827 (if inhibit-quit (setq quit-flag nil)))
3f0161d0
SM
1828 ;; Translate TAB key into control-I ASCII character, and so on.
1829 ;; Note: `read-char' does it using the `ascii-character' property.
278847cd
SM
1830 ;; We should try and use read-key instead.
1831 (let ((translation (lookup-key local-function-key-map (vector char))))
b8add347
SM
1832 (setq translated (if (arrayp translation)
1833 (aref translation 0)
1834 char)))
1835 (if (integerp translated)
1836 (setq translated (char-resolve-modifiers translated)))
c83256a0
RS
1837 (cond ((null translated))
1838 ((not (integerp translated))
1839 (setq unread-command-events (list char)
1ba764de 1840 done t))
c83256a0 1841 ((/= (logand translated ?\M-\^@) 0)
bf896a1b 1842 ;; Turn a meta-character into a character with the 0200 bit set.
c83256a0 1843 (setq code (logior (logand translated (lognot ?\M-\^@)) 128)
bf896a1b 1844 done t))
4fcc3d32
SM
1845 ((and (<= ?0 translated)
1846 (< translated (+ ?0 (min 10 read-quoted-char-radix))))
c83256a0
RS
1847 (setq code (+ (* code read-quoted-char-radix) (- translated ?0)))
1848 (and prompt (setq prompt (message "%s %c" prompt translated))))
1849 ((and (<= ?a (downcase translated))
4fcc3d32
SM
1850 (< (downcase translated)
1851 (+ ?a -10 (min 36 read-quoted-char-radix))))
92304bc8 1852 (setq code (+ (* code read-quoted-char-radix)
c83256a0
RS
1853 (+ 10 (- (downcase translated) ?a))))
1854 (and prompt (setq prompt (message "%s %c" prompt translated))))
1855 ((and (not first) (eq translated ?\C-m))
2444730b
RS
1856 (setq done t))
1857 ((not first)
c83256a0 1858 (setq unread-command-events (list char)
2444730b 1859 done t))
c83256a0 1860 (t (setq code translated
2444730b
RS
1861 done t)))
1862 (setq first nil))
bf896a1b 1863 code))
9a5336ae 1864
266725f1
SJ
1865(defun read-passwd (prompt &optional confirm default)
1866 "Read a password, prompting with PROMPT, and return it.
1867If optional CONFIRM is non-nil, read the password twice to make sure.
1868Optional DEFAULT is a default password to use instead of empty input.
1869
1870This function echoes `.' for each character that the user types.
08640de5
CY
1871
1872The user ends with RET, LFD, or ESC. DEL or C-h rubs out.
1873C-y yanks the current kill. C-u kills line.
266725f1 1874C-g quits; if `inhibit-quit' was non-nil around this function,
113fe928 1875then it returns nil if the user types C-g, but quit-flag remains set.
266725f1
SJ
1876
1877Once the caller uses the password, it can erase the password
1878by doing (clear-string STRING)."
1879 (with-local-quit
1880 (if confirm
1881 (let (success)
1882 (while (not success)
1883 (let ((first (read-passwd prompt nil default))
1884 (second (read-passwd "Confirm password: " nil default)))
1885 (if (equal first second)
1886 (progn
1887 (and (arrayp second) (clear-string second))
1888 (setq success first))
1889 (and (arrayp first) (clear-string first))
1890 (and (arrayp second) (clear-string second))
1891 (message "Password not repeated accurately; please start over")
1892 (sit-for 1))))
1893 success)
1894 (let ((pass nil)
870560eb
RS
1895 ;; Copy it so that add-text-properties won't modify
1896 ;; the object that was passed in by the caller.
1897 (prompt (copy-sequence prompt))
266725f1
SJ
1898 (c 0)
1899 (echo-keystrokes 0)
7c447c3f 1900 (cursor-in-echo-area t)
d4a263ba
CY
1901 (message-log-max nil)
1902 (stop-keys (list 'return ?\r ?\n ?\e))
1903 (rubout-keys (list 'backspace ?\b ?\177)))
a4b1de6e
EZ
1904 (add-text-properties 0 (length prompt)
1905 minibuffer-prompt-properties prompt)
266725f1
SJ
1906 (while (progn (message "%s%s"
1907 prompt
1908 (make-string (length pass) ?.))
4fd15622 1909 (setq c (read-key))
d4a263ba 1910 (not (memq c stop-keys)))
266725f1 1911 (clear-this-command-keys)
d4a263ba
CY
1912 (cond ((memq c rubout-keys) ; rubout
1913 (when (> (length pass) 0)
1914 (let ((new-pass (substring pass 0 -1)))
1915 (and (arrayp pass) (clear-string pass))
1916 (setq pass new-pass))))
4fd15622 1917 ((eq c ?\C-g) (keyboard-quit))
d4a263ba
CY
1918 ((not (numberp c)))
1919 ((= c ?\C-u) ; kill line
08640de5
CY
1920 (and (arrayp pass) (clear-string pass))
1921 (setq pass ""))
1922 ((= c ?\C-y) ; yank
1923 (let* ((str (condition-case nil
1924 (current-kill 0)
1925 (error nil)))
1926 new-pass)
1927 (when str
1928 (setq new-pass
1929 (concat pass
1930 (substring-no-properties str)))
1931 (and (arrayp pass) (clear-string pass))
1932 (setq c ?\0)
1933 (setq pass new-pass))))
d4a263ba 1934 ((characterp c) ; insert char
08640de5
CY
1935 (let* ((new-char (char-to-string c))
1936 (new-pass (concat pass new-char)))
1937 (and (arrayp pass) (clear-string pass))
1938 (clear-string new-char)
1939 (setq c ?\0)
08640de5 1940 (setq pass new-pass)))))
266725f1
SJ
1941 (message nil)
1942 (or pass default "")))))
1943
6b61353c
KH
1944;; This should be used by `call-interactively' for `n' specs.
1945(defun read-number (prompt &optional default)
3238cde3
RS
1946 "Read a numeric value in the minibuffer, prompting with PROMPT.
1947DEFAULT specifies a default value to return if the user just types RET.
1948The value of DEFAULT is inserted into PROMPT."
6b61353c
KH
1949 (let ((n nil))
1950 (when default
1951 (setq prompt
2d14d61e
MB
1952 (if (string-match "\\(\\):[ \t]*\\'" prompt)
1953 (replace-match (format " (default %s)" default) t t prompt 1)
1954 (replace-regexp-in-string "[ \t]*\\'"
1955 (format " (default %s) " default)
f8cf33b1 1956 prompt t t))))
6b61353c
KH
1957 (while
1958 (progn
1959 (let ((str (read-from-minibuffer prompt nil nil nil nil
c7863346
SM
1960 (and default
1961 (number-to-string default)))))
219f06f7
RS
1962 (condition-case nil
1963 (setq n (cond
1964 ((zerop (length str)) default)
1965 ((stringp str) (read str))))
1966 (error nil)))
6b61353c
KH
1967 (unless (numberp n)
1968 (message "Please enter a number.")
1969 (sit-for 1)
1970 t)))
1971 n))
0369eb85 1972
3ef01959
CY
1973(defun read-char-choice (prompt chars &optional inhibit-keyboard-quit)
1974 "Read and return one of CHARS, prompting for PROMPT.
1975Any input that is not one of CHARS is ignored.
1976
1977If optional argument INHIBIT-KEYBOARD-QUIT is non-nil, ignore
1978keyboard-quit events while waiting for a valid input."
1979 (unless (consp chars)
1980 (error "Called `read-char-choice' without valid char choices"))
1981 (let ((cursor-in-echo-area t)
1982 (executing-kbd-macro executing-kbd-macro)
1983 char done)
1984 (while (not done)
1985 (unless (get-text-property 0 'face prompt)
1986 (setq prompt (propertize prompt 'face 'minibuffer-prompt)))
1987 (setq char (let ((inhibit-quit inhibit-keyboard-quit))
973f1f2a 1988 (read-key prompt)))
3ef01959
CY
1989 (cond
1990 ((not (numberp char)))
1991 ((memq char chars)
1992 (setq done t))
1993 ((and executing-kbd-macro (= char -1))
1994 ;; read-event returns -1 if we are in a kbd macro and
1995 ;; there are no more events in the macro. Attempt to
1996 ;; get an event interactively.
1997 (setq executing-kbd-macro nil))))
1998 ;; Display the question with the answer.
1999 (message "%s%s" prompt (char-to-string char))
2000 char))
2001
0369eb85
CY
2002(defun sit-for (seconds &optional nodisp obsolete)
2003 "Perform redisplay, then wait for SECONDS seconds or until input is available.
2004SECONDS may be a floating-point value.
2005\(On operating systems that do not support waiting for fractions of a
2006second, floating-point values are rounded down to the nearest integer.)
2007
2008If optional arg NODISP is t, don't redisplay, just wait for input.
2009Redisplay does not happen if input is available before it starts.
0369eb85
CY
2010
2011Value is t if waited the full time with no input arriving, and nil otherwise.
2012
d8120806 2013An obsolete, but still supported form is
0369eb85 2014\(sit-for SECONDS &optional MILLISECONDS NODISP)
d8120806 2015where the optional arg MILLISECONDS specifies an additional wait period,
0369eb85 2016in milliseconds; this was useful when Emacs was built without
fd6c5134 2017floating point support."
000b06df
GM
2018 (if (numberp nodisp)
2019 (setq seconds (+ seconds (* 1e-3 nodisp))
2020 nodisp obsolete)
2021 (if obsolete (setq nodisp obsolete)))
790e0ef7
KS
2022 (cond
2023 (noninteractive
2024 (sleep-for seconds)
2025 t)
2026 ((input-pending-p)
2027 nil)
2028 ((<= seconds 0)
2029 (or nodisp (redisplay)))
2030 (t
2031 (or nodisp (redisplay))
2032 (let ((read (read-event nil nil seconds)))
2033 (or (null read)
fb1a5d8a
KS
2034 (progn
2035 ;; If last command was a prefix arg, e.g. C-u, push this event onto
2036 ;; unread-command-events as (t . EVENT) so it will be added to
2037 ;; this-command-keys by read-key-sequence.
2038 (if (eq overriding-terminal-local-map universal-argument-map)
2039 (setq read (cons t read)))
2040 (push read unread-command-events)
2041 nil))))))
f3a30a50 2042(set-advertised-calling-convention 'sit-for '(seconds &optional nodisp) "22.1")
8c51d2a2
CY
2043
2044(defun y-or-n-p (prompt &rest args)
2045 "Ask user a \"y or n\" question. Return t if answer is \"y\".
3d91e302
CY
2046The string to display to ask the question is obtained by
2047formatting the string PROMPT with arguments ARGS (see `format').
2048The result should end in a space; `y-or-n-p' adds \"(y or n) \"
2049to it.
2050
8c51d2a2
CY
2051No confirmation of the answer is requested; a single character is enough.
2052Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2053the bindings in `query-replace-map'; see the documentation of that variable
2054for more information. In this case, the useful bindings are `act', `skip',
2055`recenter', and `quit'.\)
2056
2057Under a windowing system a dialog box will be used if `last-nonmenu-event'
2058is nil and `use-dialog-box' is non-nil."
2059 ;; ¡Beware! when I tried to edebug this code, Emacs got into a weird state
2060 ;; where all the keys were unbound (i.e. it somehow got triggered
2061 ;; within read-key, apparently). I had to kill it.
2062 (let ((answer 'recenter))
2063 (if (and (display-popup-menus-p)
2064 (listp last-nonmenu-event)
2065 use-dialog-box)
2066 (setq answer
2067 (x-popup-dialog t `(,prompt ("yes" . act) ("No" . skip))))
2068 (setq prompt (concat (apply 'format prompt args)
2069 (if (eq ?\s (aref prompt (1- (length prompt))))
2070 "" " ")
2071 "(y or n) "))
2072 (while
2073 (let* ((key
2074 (let ((cursor-in-echo-area t))
2075 (when minibuffer-auto-raise
2076 (raise-frame (window-frame (minibuffer-window))))
2077 (read-key (propertize (if (eq answer 'recenter)
2078 prompt
2079 (concat "Please answer y or n. "
2080 prompt))
2081 'face 'minibuffer-prompt)))))
2082 (setq answer (lookup-key query-replace-map (vector key) t))
2083 (cond
2084 ((memq answer '(skip act)) nil)
2085 ((eq answer 'recenter) (recenter) t)
2086 ((memq answer '(exit-prefix quit)) (signal 'quit nil) t)
2087 (t t)))
2088 (ding)
2089 (discard-input)))
2090 (let ((ret (eq answer 'act)))
2091 (unless noninteractive
2092 (message "%s %s" prompt (if ret "y" "n")))
2093 ret)))
2094
e0e4cb7a 2095\f
2493767e
RS
2096;;; Atomic change groups.
2097
69cae2d4
RS
2098(defmacro atomic-change-group (&rest body)
2099 "Perform BODY as an atomic change group.
2100This means that if BODY exits abnormally,
2101all of its changes to the current buffer are undone.
b9ab4064 2102This works regardless of whether undo is enabled in the buffer.
69cae2d4
RS
2103
2104This mechanism is transparent to ordinary use of undo;
2105if undo is enabled in the buffer and BODY succeeds, the
2106user can undo the change normally."
6273dc68 2107 (declare (indent 0) (debug t))
69cae2d4
RS
2108 (let ((handle (make-symbol "--change-group-handle--"))
2109 (success (make-symbol "--change-group-success--")))
2110 `(let ((,handle (prepare-change-group))
cf191706
RS
2111 ;; Don't truncate any undo data in the middle of this.
2112 (undo-outer-limit nil)
2113 (undo-limit most-positive-fixnum)
2114 (undo-strong-limit most-positive-fixnum)
69cae2d4
RS
2115 (,success nil))
2116 (unwind-protect
2117 (progn
2118 ;; This is inside the unwind-protect because
2119 ;; it enables undo if that was disabled; we need
2120 ;; to make sure that it gets disabled again.
2121 (activate-change-group ,handle)
2122 ,@body
2123 (setq ,success t))
2124 ;; Either of these functions will disable undo
2125 ;; if it was disabled before.
2126 (if ,success
2127 (accept-change-group ,handle)
2128 (cancel-change-group ,handle))))))
2129
62ea1306 2130(defun prepare-change-group (&optional buffer)
69cae2d4 2131 "Return a handle for the current buffer's state, for a change group.
62ea1306 2132If you specify BUFFER, make a handle for BUFFER's state instead.
69cae2d4
RS
2133
2134Pass the handle to `activate-change-group' afterward to initiate
2135the actual changes of the change group.
2136
2137To finish the change group, call either `accept-change-group' or
2138`cancel-change-group' passing the same handle as argument. Call
2139`accept-change-group' to accept the changes in the group as final;
2140call `cancel-change-group' to undo them all. You should use
2141`unwind-protect' to make sure the group is always finished. The call
2142to `activate-change-group' should be inside the `unwind-protect'.
2143Once you finish the group, don't use the handle again--don't try to
2144finish the same group twice. For a simple example of correct use, see
2145the source code of `atomic-change-group'.
2146
2147The handle records only the specified buffer. To make a multibuffer
2148change group, call this function once for each buffer you want to
2149cover, then use `nconc' to combine the returned values, like this:
2150
2151 (nconc (prepare-change-group buffer-1)
2152 (prepare-change-group buffer-2))
2153
2154You can then activate that multibuffer change group with a single
2155call to `activate-change-group' and finish it with a single call
2156to `accept-change-group' or `cancel-change-group'."
2157
62ea1306
RS
2158 (if buffer
2159 (list (cons buffer (with-current-buffer buffer buffer-undo-list)))
2160 (list (cons (current-buffer) buffer-undo-list))))
69cae2d4
RS
2161
2162(defun activate-change-group (handle)
2163 "Activate a change group made with `prepare-change-group' (which see)."
2164 (dolist (elt handle)
2165 (with-current-buffer (car elt)
2166 (if (eq buffer-undo-list t)
2167 (setq buffer-undo-list nil)))))
2168
2169(defun accept-change-group (handle)
2170 "Finish a change group made with `prepare-change-group' (which see).
2171This finishes the change group by accepting its changes as final."
2172 (dolist (elt handle)
2173 (with-current-buffer (car elt)
2174 (if (eq elt t)
2175 (setq buffer-undo-list t)))))
2176
2177(defun cancel-change-group (handle)
2178 "Finish a change group made with `prepare-change-group' (which see).
2179This finishes the change group by reverting all of its changes."
2180 (dolist (elt handle)
2181 (with-current-buffer (car elt)
2182 (setq elt (cdr elt))
d21cba62
MR
2183 (save-restriction
2184 ;; Widen buffer temporarily so if the buffer was narrowed within
2185 ;; the body of `atomic-change-group' all changes can be undone.
2186 (widen)
2187 (let ((old-car
2188 (if (consp elt) (car elt)))
2189 (old-cdr
2190 (if (consp elt) (cdr elt))))
2191 ;; Temporarily truncate the undo log at ELT.
2192 (when (consp elt)
2193 (setcar elt nil) (setcdr elt nil))
2194 (unless (eq last-command 'undo) (undo-start))
2195 ;; Make sure there's no confusion.
2196 (when (and (consp elt) (not (eq elt (last pending-undo-list))))
2197 (error "Undoing to some unrelated state"))
2198 ;; Undo it all.
2199 (save-excursion
2200 (while (listp pending-undo-list) (undo-more 1)))
2201 ;; Reset the modified cons cell ELT to its original content.
2202 (when (consp elt)
2203 (setcar elt old-car)
2204 (setcdr elt old-cdr))
2205 ;; Revert the undo info to what it was when we grabbed the state.
2206 (setq buffer-undo-list elt))))))
69cae2d4 2207\f
c4f484f2
RS
2208;;;; Display-related functions.
2209
a9d956be
RS
2210;; For compatibility.
2211(defalias 'redraw-modeline 'force-mode-line-update)
2212
9a5336ae 2213(defun force-mode-line-update (&optional all)
6b61353c
KH
2214 "Force redisplay of the current buffer's mode line and header line.
2215With optional non-nil ALL, force redisplay of all mode lines and
2216header lines. This function also forces recomputation of the
2217menu bar menus and the frame title."
03a74b84 2218 (if all (with-current-buffer (other-buffer)))
9a5336ae
JB
2219 (set-buffer-modified-p (buffer-modified-p)))
2220
aa3b4ded 2221(defun momentary-string-display (string pos &optional exit-char message)
be9b65ac 2222 "Momentarily display STRING in the buffer at POS.
12092fb3 2223Display remains until next event is input.
dbf284be 2224If POS is a marker, only its position is used; its buffer is ignored.
12092fb3
EZ
2225Optional third arg EXIT-CHAR can be a character, event or event
2226description list. EXIT-CHAR defaults to SPC. If the input is
2227EXIT-CHAR it is swallowed; otherwise it is then available as
2228input (as a command if nothing else).
be9b65ac
DL
2229Display MESSAGE (optional fourth arg) in the echo area.
2230If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
b754307b 2231 (or exit-char (setq exit-char ?\s))
f70c4736 2232 (let ((ol (make-overlay pos pos))
bc91aee9 2233 (str (copy-sequence string)))
be9b65ac 2234 (unwind-protect
f70c4736
SM
2235 (progn
2236 (save-excursion
bc91aee9 2237 (overlay-put ol 'after-string str)
f70c4736
SM
2238 (goto-char pos)
2239 ;; To avoid trouble with out-of-bounds position
2240 (setq pos (point))
bc91aee9 2241 ;; If the string end is off screen, recenter now.
f70c4736
SM
2242 (if (<= (window-end nil t) pos)
2243 (recenter (/ (window-height) 2))))
2244 (message (or message "Type %s to continue editing.")
2245 (single-key-description exit-char))
fe40dc63
JB
2246 (let ((event (read-event)))
2247 ;; `exit-char' can be an event, or an event description list.
2248 (or (eq event exit-char)
2249 (eq event (event-convert-list exit-char))
2250 (setq unread-command-events (list event)))))
f70c4736 2251 (delete-overlay ol))))
be9b65ac 2252
9a5336ae 2253\f
aa3b4ded
SM
2254;;;; Overlay operations
2255
2256(defun copy-overlay (o)
2257 "Return a copy of overlay O."
48b1e7cf
SM
2258 (let ((o1 (if (overlay-buffer o)
2259 (make-overlay (overlay-start o) (overlay-end o)
2260 ;; FIXME: there's no easy way to find the
2261 ;; insertion-type of the two markers.
2262 (overlay-buffer o))
2263 (let ((o1 (make-overlay (point-min) (point-min))))
2264 (delete-overlay o1)
28f0b072 2265 o1)))
aa3b4ded
SM
2266 (props (overlay-properties o)))
2267 (while props
2268 (overlay-put o1 (pop props) (pop props)))
2269 o1))
2270
f24485f1 2271(defun remove-overlays (&optional beg end name val)
aa3b4ded 2272 "Clear BEG and END of overlays whose property NAME has value VAL.
cba61075
JB
2273Overlays might be moved and/or split.
2274BEG and END default respectively to the beginning and end of buffer."
d6f5ac10 2275 ;; This speeds up the loops over overlays.
f24485f1
MY
2276 (unless beg (setq beg (point-min)))
2277 (unless end (setq end (point-max)))
ee6bb693 2278 (overlay-recenter end)
aa3b4ded
SM
2279 (if (< end beg)
2280 (setq beg (prog1 end (setq end beg))))
2281 (save-excursion
2282 (dolist (o (overlays-in beg end))
2283 (when (eq (overlay-get o name) val)
2284 ;; Either push this overlay outside beg...end
2285 ;; or split it to exclude beg...end
2286 ;; or delete it entirely (if it is contained in beg...end).
2287 (if (< (overlay-start o) beg)
2288 (if (> (overlay-end o) end)
2289 (progn
2290 (move-overlay (copy-overlay o)
2291 (overlay-start o) beg)
2292 (move-overlay o end (overlay-end o)))
2293 (move-overlay o (overlay-start o) beg))
2294 (if (> (overlay-end o) end)
2295 (move-overlay o end (overlay-end o))
2296 (delete-overlay o)))))))
c5802acf 2297\f
9a5336ae
JB
2298;;;; Miscellanea.
2299
4fb17037
RS
2300(defvar suspend-hook nil
2301 "Normal hook run by `suspend-emacs', before suspending.")
2302
2303(defvar suspend-resume-hook nil
2304 "Normal hook run by `suspend-emacs', after Emacs is continued.")
2305
784bc7cd
RS
2306(defvar temp-buffer-show-hook nil
2307 "Normal hook run by `with-output-to-temp-buffer' after displaying the buffer.
2308When the hook runs, the temporary buffer is current, and the window it
5247a8e6 2309was displayed in is selected.")
784bc7cd
RS
2310
2311(defvar temp-buffer-setup-hook nil
2312 "Normal hook run by `with-output-to-temp-buffer' at the start.
2313When the hook runs, the temporary buffer is current.
2314This hook is normally set up with a function to put the buffer in Help
2315mode.")
2316
448b61c9
RS
2317;; Avoid compiler warnings about this variable,
2318;; which has a special meaning on certain system types.
2319(defvar buffer-file-type nil
2320 "Non-nil if the visited file is a binary file.
2321This variable is meaningful on MS-DOG and Windows NT.
2322On those systems, it is automatically local in every buffer.
2323On other systems, this variable is normally always nil.")
28ac46f8
JPW
2324
2325;; The `assert' macro from the cl package signals
2326;; `cl-assertion-failed' at runtime so always define it.
2327(put 'cl-assertion-failed 'error-conditions '(error))
6bdad9ae 2328(put 'cl-assertion-failed 'error-message (purecopy "Assertion failed"))
28ac46f8 2329
d8869c65
CY
2330(defconst user-emacs-directory
2331 (if (eq system-type 'ms-dos)
2332 ;; MS-DOS cannot have initial dot.
2333 "~/_emacs.d/"
2334 "~/.emacs.d/")
2335 "Directory beneath which additional per-user Emacs-specific files are placed.
2336Various programs in Emacs store information in this directory.
d6c180c4
JB
2337Note that this should end with a directory separator.
2338See also `locate-user-emacs-file'.")
2339
2340(defun locate-user-emacs-file (new-name &optional old-name)
2341 "Return an absolute per-user Emacs-specific file name.
2342If OLD-NAME is non-nil and ~/OLD-NAME exists, return ~/OLD-NAME.
2343Else return NEW-NAME in `user-emacs-directory', creating the
2344directory if it does not exist."
2345 (convert-standard-filename
2346 (let* ((home (concat "~" (or init-file-user "")))
2347 (at-home (and old-name (expand-file-name old-name home))))
2348 (if (and at-home (file-readable-p at-home))
2349 at-home
2bea2795
JB
2350 ;; Make sure `user-emacs-directory' exists,
2351 ;; unless we're in batch mode or dumping Emacs
2352 (or noninteractive
2353 purify-flag
2354 (file-accessible-directory-p (directory-file-name user-emacs-directory))
2355 (make-directory user-emacs-directory))
03a74b84
SM
2356 (abbreviate-file-name
2357 (expand-file-name new-name user-emacs-directory))))))
d8869c65 2358
c4f484f2
RS
2359\f
2360;;;; Misc. useful functions.
448b61c9 2361
c4f484f2
RS
2362(defun find-tag-default ()
2363 "Determine default tag to search for, based on text at point.
2364If there is no plausible default, return nil."
9db3bfae
MR
2365 (let (from to bound)
2366 (when (or (progn
2367 ;; Look at text around `point'.
2368 (save-excursion
2369 (skip-syntax-backward "w_") (setq from (point)))
2370 (save-excursion
2371 (skip-syntax-forward "w_") (setq to (point)))
2372 (> to from))
2373 ;; Look between `line-beginning-position' and `point'.
2374 (save-excursion
2375 (and (setq bound (line-beginning-position))
2376 (skip-syntax-backward "^w_" bound)
2377 (> (setq to (point)) bound)
2378 (skip-syntax-backward "w_")
2379 (setq from (point))))
2380 ;; Look between `point' and `line-end-position'.
2381 (save-excursion
2382 (and (setq bound (line-end-position))
2383 (skip-syntax-forward "^w_" bound)
2384 (< (setq from (point)) bound)
2385 (skip-syntax-forward "w_")
2386 (setq to (point)))))
2387 (buffer-substring-no-properties from to))))
a860d25f 2388
c4f484f2
RS
2389(defun play-sound (sound)
2390 "SOUND is a list of the form `(sound KEYWORD VALUE...)'.
2391The following keywords are recognized:
9a5336ae 2392
c4f484f2
RS
2393 :file FILE - read sound data from FILE. If FILE isn't an
2394absolute file name, it is searched in `data-directory'.
9a5336ae 2395
c4f484f2
RS
2396 :data DATA - read sound data from string DATA.
2397
2398Exactly one of :file or :data must be present.
2399
2400 :volume VOL - set volume to VOL. VOL must an integer in the
2401range 0..100 or a float in the range 0..1.0. If not specified,
2402don't change the volume setting of the sound device.
9a5336ae 2403
c4f484f2 2404 :device DEVICE - play sound on DEVICE. If not specified,
d7f90d6c
JB
2405a system-dependent default device name is used.
2406
2407Note: :data and :device are currently not supported on Windows."
c4f484f2
RS
2408 (if (fboundp 'play-sound-internal)
2409 (play-sound-internal sound)
2410 (error "This Emacs binary lacks sound support")))
9a5336ae 2411
0ef97535
GM
2412(declare-function w32-shell-dos-semantics "w32-fns" nil)
2413
c4f484f2 2414(defun shell-quote-argument (argument)
d7f90d6c 2415 "Quote ARGUMENT for passing as argument to an inferior shell."
4bbf6b41
JR
2416 (if (or (eq system-type 'ms-dos)
2417 (and (eq system-type 'windows-nt) (w32-shell-dos-semantics)))
c4f484f2
RS
2418 ;; Quote using double quotes, but escape any existing quotes in
2419 ;; the argument with backslashes.
2420 (let ((result "")
2421 (start 0)
2422 end)
2423 (if (or (null (string-match "[^\"]" argument))
2424 (< (match-end 0) (length argument)))
2425 (while (string-match "[\"]" argument start)
2426 (setq end (match-beginning 0)
2427 result (concat result (substring argument start end)
2428 "\\" (substring argument end (1+ end)))
2429 start (1+ end))))
2430 (concat "\"" result (substring argument start) "\""))
4bbf6b41
JR
2431 (if (equal argument "")
2432 "''"
2433 ;; Quote everything except POSIX filename characters.
2434 ;; This should be safe enough even for really weird shells.
2435 (let ((result "") (start 0) end)
2436 (while (string-match "[^-0-9a-zA-Z_./]" argument start)
2437 (setq end (match-beginning 0)
2438 result (concat result (substring argument start end)
2439 "\\" (substring argument end (1+ end)))
2440 start (1+ end)))
2441 (concat result (substring argument start))))))
3e457225
RS
2442
2443(defun string-or-null-p (object)
2444 "Return t if OBJECT is a string or nil.
2445Otherwise, return nil."
2446 (or (stringp object) (null object)))
2447
26715e1b 2448(defun booleanp (object)
ac6ca7ba
KR
2449 "Return t if OBJECT is one of the two canonical boolean values: t or nil.
2450Otherwise, return nil."
2451 (and (memq object '(nil t)) t))
26715e1b 2452
1627b55f 2453(defun field-at-pos (pos)
d7f90d6c 2454 "Return the field at position POS, taking stickiness etc into account."
1ecaae6c
NR
2455 (let ((raw-field (get-char-property (field-beginning pos) 'field)))
2456 (if (eq raw-field 'boundary)
2457 (get-char-property (1- (field-end pos)) 'field)
2458 raw-field)))
2459
c4f484f2
RS
2460\f
2461;;;; Support for yanking and text properties.
9a5336ae 2462
2493767e
RS
2463(defvar yank-excluded-properties)
2464
8ed59ad5
KS
2465(defun remove-yank-excluded-properties (start end)
2466 "Remove `yank-excluded-properties' between START and END positions.
2467Replaces `category' properties with their defined properties."
2468 (let ((inhibit-read-only t))
0f00e948
EZ
2469 ;; Replace any `category' property with the properties it stands
2470 ;; for. This is to remove `mouse-face' properties that are placed
2471 ;; on categories in *Help* buffers' buttons. See
2472 ;; http://lists.gnu.org/archive/html/emacs-devel/2002-04/msg00648.html
2473 ;; for the details.
8ed59ad5
KS
2474 (unless (memq yank-excluded-properties '(t nil))
2475 (save-excursion
2476 (goto-char start)
2477 (while (< (point) end)
2478 (let ((cat (get-text-property (point) 'category))
2479 run-end)
8ed59ad5
KS
2480 (setq run-end
2481 (next-single-property-change (point) 'category nil end))
ebaa3349
RS
2482 (when cat
2483 (let (run-end2 original)
2484 (remove-list-of-text-properties (point) run-end '(category))
2485 (while (< (point) run-end)
2486 (setq run-end2 (next-property-change (point) nil run-end))
2487 (setq original (text-properties-at (point)))
2488 (set-text-properties (point) run-end2 (symbol-plist cat))
2489 (add-text-properties (point) run-end2 original)
2490 (goto-char run-end2))))
2491 (goto-char run-end)))))
8ed59ad5
KS
2492 (if (eq yank-excluded-properties t)
2493 (set-text-properties start end nil)
ebaa3349 2494 (remove-list-of-text-properties start end yank-excluded-properties))))
8ed59ad5 2495
e0e80ec9
KS
2496(defvar yank-undo-function)
2497
2498(defun insert-for-yank (string)
6b61353c
KH
2499 "Calls `insert-for-yank-1' repetitively for each `yank-handler' segment.
2500
2501See `insert-for-yank-1' for more details."
2502 (let (to)
2503 (while (setq to (next-single-property-change 0 'yank-handler string))
2504 (insert-for-yank-1 (substring string 0 to))
2505 (setq string (substring string to))))
2506 (insert-for-yank-1 string))
2507
2508(defun insert-for-yank-1 (string)
e0e80ec9 2509 "Insert STRING at point, stripping some text properties.
6b61353c 2510
e0e80ec9
KS
2511Strip text properties from the inserted text according to
2512`yank-excluded-properties'. Otherwise just like (insert STRING).
2513
374d3fe7 2514If STRING has a non-nil `yank-handler' property on the first character,
cc295a82 2515the normal insert behavior is modified in various ways. The value of
fbe13428 2516the yank-handler property must be a list with one to four elements
9dd10e25 2517with the following format: (FUNCTION PARAM NOEXCLUDE UNDO).
e0e80ec9
KS
2518When FUNCTION is present and non-nil, it is called instead of `insert'
2519 to insert the string. FUNCTION takes one argument--the object to insert.
2520If PARAM is present and non-nil, it replaces STRING as the object
2521 passed to FUNCTION (or `insert'); for example, if FUNCTION is
2522 `yank-rectangle', PARAM may be a list of strings to insert as a
2523 rectangle.
2524If NOEXCLUDE is present and non-nil, the normal removal of the
5612fd08 2525 `yank-excluded-properties' is not performed; instead FUNCTION is
e0e80ec9
KS
2526 responsible for removing those properties. This may be necessary
2527 if FUNCTION adjusts point before or after inserting the object.
2528If UNDO is present and non-nil, it is a function that will be called
2529 by `yank-pop' to undo the insertion of the current object. It is
f1180544 2530 called with two arguments, the start and end of the current region.
9dd10e25 2531 FUNCTION may set `yank-undo-function' to override the UNDO value."
57596fb6
KS
2532 (let* ((handler (and (stringp string)
2533 (get-text-property 0 'yank-handler string)))
2534 (param (or (nth 1 handler) string))
4f0f29aa 2535 (opoint (point))
029fd82c 2536 (inhibit-read-only inhibit-read-only)
4f0f29aa
RS
2537 end)
2538
57596fb6
KS
2539 (setq yank-undo-function t)
2540 (if (nth 0 handler) ;; FUNCTION
2541 (funcall (car handler) param)
e0e80ec9 2542 (insert param))
4f0f29aa
RS
2543 (setq end (point))
2544
029fd82c
CY
2545 ;; Prevent read-only properties from interfering with the
2546 ;; following text property changes.
2547 (setq inhibit-read-only t)
2548
4f0f29aa
RS
2549 ;; What should we do with `font-lock-face' properties?
2550 (if font-lock-defaults
2551 ;; No, just wipe them.
2552 (remove-list-of-text-properties opoint end '(font-lock-face))
2553 ;; Convert them to `face'.
2554 (save-excursion
2555 (goto-char opoint)
2556 (while (< (point) end)
2557 (let ((face (get-text-property (point) 'font-lock-face))
2558 run-end)
2559 (setq run-end
2560 (next-single-property-change (point) 'font-lock-face nil end))
2561 (when face
2562 (remove-text-properties (point) run-end '(font-lock-face nil))
2563 (put-text-property (point) run-end 'face face))
2564 (goto-char run-end)))))
2565
57596fb6 2566 (unless (nth 2 handler) ;; NOEXCLUDE
e0e80ec9 2567 (remove-yank-excluded-properties opoint (point)))
631890d8
RS
2568
2569 ;; If last inserted char has properties, mark them as rear-nonsticky.
2570 (if (and (> end opoint)
2571 (text-properties-at (1- end)))
2572 (put-text-property (1- end) end 'rear-nonsticky t))
2573
c8227332 2574 (if (eq yank-undo-function t) ;; not set by FUNCTION
57596fb6 2575 (setq yank-undo-function (nth 3 handler))) ;; UNDO
c8227332 2576 (if (nth 4 handler) ;; COMMAND
57596fb6 2577 (setq this-command (nth 4 handler)))))
f1180544 2578
a478f3e1
JB
2579(defun insert-buffer-substring-no-properties (buffer &optional start end)
2580 "Insert before point a substring of BUFFER, without text properties.
3b8690f6 2581BUFFER may be a buffer or a buffer name.
f8cf33b1
JB
2582Arguments START and END are character positions specifying the substring.
2583They default to the values of (point-min) and (point-max) in BUFFER."
3b8690f6 2584 (let ((opoint (point)))
a478f3e1 2585 (insert-buffer-substring buffer start end)
3b8690f6
KS
2586 (let ((inhibit-read-only t))
2587 (set-text-properties opoint (point) nil))))
2588
a478f3e1
JB
2589(defun insert-buffer-substring-as-yank (buffer &optional start end)
2590 "Insert before point a part of BUFFER, stripping some text properties.
2591BUFFER may be a buffer or a buffer name.
f8cf33b1
JB
2592Arguments START and END are character positions specifying the substring.
2593They default to the values of (point-min) and (point-max) in BUFFER.
a478f3e1
JB
2594Strip text properties from the inserted text according to
2595`yank-excluded-properties'."
6b61353c
KH
2596 ;; Since the buffer text should not normally have yank-handler properties,
2597 ;; there is no need to handle them here.
3b8690f6 2598 (let ((opoint (point)))
a478f3e1 2599 (insert-buffer-substring buffer start end)
8ed59ad5 2600 (remove-yank-excluded-properties opoint (point))))
3b8690f6 2601
2493767e 2602\f
c4f484f2 2603;;;; Synchronous shell commands.
2493767e 2604
be9b65ac
DL
2605(defun start-process-shell-command (name buffer &rest args)
2606 "Start a program in a subprocess. Return the process object for it.
be9b65ac 2607NAME is name for process. It is modified if necessary to make it unique.
54ce7cbf 2608BUFFER is the buffer (or buffer name) to associate with the process.
be9b65ac
DL
2609 Process output goes at end of that buffer, unless you specify
2610 an output stream or filter function to handle the output.
2611 BUFFER may be also nil, meaning that this process is not associated
2612 with any buffer
03a74b84
SM
2613COMMAND is the shell command to run.
2614
2615An old calling convention accepted any number of arguments after COMMAND,
2616which were just concatenated to COMMAND. This is still supported but strongly
fd6c5134 2617discouraged."
b59f6d7a
RS
2618 ;; We used to use `exec' to replace the shell with the command,
2619 ;; but that failed to handle (...) and semicolon, etc.
7c2fb837
DN
2620 (start-process name buffer shell-file-name shell-command-switch
2621 (mapconcat 'identity args " ")))
f3ed9aca 2622(set-advertised-calling-convention 'start-process-shell-command
f3a30a50 2623 '(name buffer command) "23.1")
f3ed9aca 2624
a9e11582
MA
2625(defun start-file-process-shell-command (name buffer &rest args)
2626 "Start a program in a subprocess. Return the process object for it.
fd6c5134 2627Similar to `start-process-shell-command', but calls `start-file-process'."
a9e11582
MA
2628 (start-file-process
2629 name buffer
2630 (if (file-remote-p default-directory) "/bin/sh" shell-file-name)
2631 (if (file-remote-p default-directory) "-c" shell-command-switch)
2632 (mapconcat 'identity args " ")))
f3ed9aca 2633(set-advertised-calling-convention 'start-file-process-shell-command
f3a30a50 2634 '(name buffer command) "23.1")
a9e11582 2635
93aca633
MB
2636(defun call-process-shell-command (command &optional infile buffer display
2637 &rest args)
2638 "Execute the shell command COMMAND synchronously in separate process.
2639The remaining arguments are optional.
2640The program's input comes from file INFILE (nil means `/dev/null').
2641Insert output in BUFFER before point; t means current buffer;
2642 nil for BUFFER means discard it; 0 means discard and don't wait.
2643BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
2644REAL-BUFFER says what to do with standard output, as above,
2645while STDERR-FILE says what to do with standard error in the child.
2646STDERR-FILE may be nil (discard standard error output),
2647t (mix it with ordinary output), or a file name string.
2648
2649Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
2650Remaining arguments are strings passed as additional arguments for COMMAND.
2651Wildcards and redirection are handled as usual in the shell.
2652
2653If BUFFER is 0, `call-process-shell-command' returns immediately with value nil.
2654Otherwise it waits for COMMAND to terminate and returns a numeric exit
2655status or a signal description string.
2656If you quit, the process is killed with SIGINT, or SIGKILL if you quit again."
7c2fb837
DN
2657 ;; We used to use `exec' to replace the shell with the command,
2658 ;; but that failed to handle (...) and semicolon, etc.
2659 (call-process shell-file-name
2660 infile buffer display
2661 shell-command-switch
2662 (mapconcat 'identity (cons command args) " ")))
a9e11582
MA
2663
2664(defun process-file-shell-command (command &optional infile buffer display
2665 &rest args)
2666 "Process files synchronously in a separate process.
2667Similar to `call-process-shell-command', but calls `process-file'."
2668 (process-file
2669 (if (file-remote-p default-directory) "/bin/sh" shell-file-name)
2670 infile buffer display
2671 (if (file-remote-p default-directory) "-c" shell-command-switch)
2672 (mapconcat 'identity (cons command args) " ")))
a7ed4c2a 2673\f
c4f484f2
RS
2674;;;; Lisp macros to do various things temporarily.
2675
83f57f49
MR
2676(defmacro with-current-buffer (buffer-or-name &rest body)
2677 "Execute the forms in BODY with BUFFER-OR-NAME temporarily current.
2678BUFFER-OR-NAME must be a buffer or the name of an existing buffer.
2679The value returned is the value of the last form in BODY. See
2680also `with-temp-buffer'."
d47f7515
SM
2681 (declare (indent 1) (debug t))
2682 `(save-current-buffer
83f57f49 2683 (set-buffer ,buffer-or-name)
d47f7515
SM
2684 ,@body))
2685
2686(defmacro with-selected-window (window &rest body)
2687 "Execute the forms in BODY with WINDOW as the selected window.
2688The value returned is the value of the last form in BODY.
4c6d1e16 2689
a5094f72
MR
2690This macro saves and restores the selected window, as well as the
2691selected window of each frame. It does not change the order of
2692recently selected windows. If the previously selected window of
2693some frame is no longer live at the end of BODY, that frame's
2694selected window is left alone. If the selected window is no
2695longer live, then whatever window is selected at the end of BODY
2696remains selected.
2697
2698This macro uses `save-current-buffer' to save and restore the
2699current buffer, since otherwise its normal operation could
2700potentially make a different buffer current. It does not alter
2701the buffer list ordering."
d47f7515 2702 (declare (indent 1) (debug t))
4df623c0
RS
2703 ;; Most of this code is a copy of save-selected-window.
2704 `(let ((save-selected-window-window (selected-window))
3f71ad3a
RS
2705 ;; It is necessary to save all of these, because calling
2706 ;; select-window changes frame-selected-window for whatever
2707 ;; frame that window is in.
4df623c0
RS
2708 (save-selected-window-alist
2709 (mapcar (lambda (frame) (list frame (frame-selected-window frame)))
2710 (frame-list))))
4c6d1e16
RS
2711 (save-current-buffer
2712 (unwind-protect
2713 (progn (select-window ,window 'norecord)
2714 ,@body)
2715 (dolist (elt save-selected-window-alist)
2716 (and (frame-live-p (car elt))
2717 (window-live-p (cadr elt))
a5094f72
MR
2718 (set-frame-selected-window (car elt) (cadr elt) 'norecord)))
2719 (when (window-live-p save-selected-window-window)
2720 (select-window save-selected-window-window 'norecord))))))
a7f284ec 2721
c3e242d3
KL
2722(defmacro with-selected-frame (frame &rest body)
2723 "Execute the forms in BODY with FRAME as the selected frame.
2724The value returned is the value of the last form in BODY.
a5094f72
MR
2725
2726This macro neither changes the order of recently selected windows
2727nor the buffer list."
c3e242d3 2728 (declare (indent 1) (debug t))
632210dd
KL
2729 (let ((old-frame (make-symbol "old-frame"))
2730 (old-buffer (make-symbol "old-buffer")))
2731 `(let ((,old-frame (selected-frame))
2732 (,old-buffer (current-buffer)))
2733 (unwind-protect
a5094f72 2734 (progn (select-frame ,frame 'norecord)
632210dd 2735 ,@body)
a5094f72
MR
2736 (when (frame-live-p ,old-frame)
2737 (select-frame ,old-frame 'norecord))
2738 (when (buffer-live-p ,old-buffer)
2739 (set-buffer ,old-buffer))))))
c3e242d3 2740
e5bb8a8c
SM
2741(defmacro with-temp-file (file &rest body)
2742 "Create a new buffer, evaluate BODY there, and write the buffer to FILE.
2743The value returned is the value of the last form in BODY.
a2fdb55c 2744See also `with-temp-buffer'."
f291fe60 2745 (declare (indent 1) (debug t))
a7ed4c2a 2746 (let ((temp-file (make-symbol "temp-file"))
a2fdb55c
EN
2747 (temp-buffer (make-symbol "temp-buffer")))
2748 `(let ((,temp-file ,file)
2749 (,temp-buffer
2750 (get-buffer-create (generate-new-buffer-name " *temp file*"))))
2751 (unwind-protect
2752 (prog1
2753 (with-current-buffer ,temp-buffer
e5bb8a8c 2754 ,@body)
a2fdb55c 2755 (with-current-buffer ,temp-buffer
ab1d3835 2756 (write-region nil nil ,temp-file nil 0)))
a2fdb55c
EN
2757 (and (buffer-name ,temp-buffer)
2758 (kill-buffer ,temp-buffer))))))
2759
e5bb8a8c 2760(defmacro with-temp-message (message &rest body)
a600effe 2761 "Display MESSAGE temporarily if non-nil while BODY is evaluated.
e5bb8a8c
SM
2762The original message is restored to the echo area after BODY has finished.
2763The value returned is the value of the last form in BODY.
a600effe
SM
2764MESSAGE is written to the message log buffer if `message-log-max' is non-nil.
2765If MESSAGE is nil, the echo area and message log buffer are unchanged.
2766Use a MESSAGE of \"\" to temporarily clear the echo area."
f291fe60 2767 (declare (debug t) (indent 1))
110201c8
SM
2768 (let ((current-message (make-symbol "current-message"))
2769 (temp-message (make-symbol "with-temp-message")))
2770 `(let ((,temp-message ,message)
2771 (,current-message))
e5bb8a8c
SM
2772 (unwind-protect
2773 (progn
110201c8
SM
2774 (when ,temp-message
2775 (setq ,current-message (current-message))
aadf7ff3 2776 (message "%s" ,temp-message))
e5bb8a8c 2777 ,@body)
cad84646
RS
2778 (and ,temp-message
2779 (if ,current-message
2780 (message "%s" ,current-message)
2781 (message nil)))))))
e5bb8a8c
SM
2782
2783(defmacro with-temp-buffer (&rest body)
2784 "Create a temporary buffer, and evaluate BODY there like `progn'.
a2fdb55c 2785See also `with-temp-file' and `with-output-to-string'."
d47f7515 2786 (declare (indent 0) (debug t))
a2fdb55c 2787 (let ((temp-buffer (make-symbol "temp-buffer")))
9166dbf6 2788 `(let ((,temp-buffer (generate-new-buffer " *temp*")))
4a5e1832
SM
2789 ;; FIXME: kill-buffer can change current-buffer in some odd cases.
2790 (with-current-buffer ,temp-buffer
2791 (unwind-protect
2792 (progn ,@body)
2793 (and (buffer-name ,temp-buffer)
2794 (kill-buffer ,temp-buffer)))))))
a2fdb55c 2795
83a5aac5 2796(defmacro with-silent-modifications (&rest body)
f291fe60 2797 "Execute BODY, pretending it does not modify the buffer.
83a5aac5
SM
2798If BODY performs real modifications to the buffer's text, other
2799than cosmetic ones, undo data may become corrupted.
2800Typically used around modifications of text-properties which do not really
2801affect the buffer's content."
2802 (declare (debug t) (indent 0))
2803 (let ((modified (make-symbol "modified")))
2804 `(let* ((,modified (buffer-modified-p))
2805 (buffer-undo-list t)
2806 (inhibit-read-only t)
2807 (inhibit-modification-hooks t)
2808 deactivate-mark
2809 ;; Avoid setting and removing file locks and checking
2810 ;; buffer's uptodate-ness w.r.t the underlying file.
2811 buffer-file-name
2812 buffer-file-truename)
2813 (unwind-protect
2814 (progn
2815 ,@body)
2816 (unless ,modified
2817 (restore-buffer-modified-p nil))))))
2818
5db7925d
RS
2819(defmacro with-output-to-string (&rest body)
2820 "Execute BODY, return the text it sent to `standard-output', as a string."
d47f7515 2821 (declare (indent 0) (debug t))
a2fdb55c
EN
2822 `(let ((standard-output
2823 (get-buffer-create (generate-new-buffer-name " *string-output*"))))
86ec740e
RF
2824 (unwind-protect
2825 (progn
2826 (let ((standard-output standard-output))
2827 ,@body)
2828 (with-current-buffer standard-output
2829 (buffer-string)))
2830 (kill-buffer standard-output))))
2ec9c94e 2831
0764e16f 2832(defmacro with-local-quit (&rest body)
53a7160c 2833 "Execute BODY, allowing quits to terminate BODY but not escape further.
b9308c61 2834When a quit terminates BODY, `with-local-quit' returns nil but
60f7e8b6
RS
2835requests another quit. That quit will be processed as soon as quitting
2836is allowed once again. (Immediately, if `inhibit-quit' is nil.)"
12320833 2837 (declare (debug t) (indent 0))
0764e16f
SM
2838 `(condition-case nil
2839 (let ((inhibit-quit nil))
2840 ,@body)
113fe928
RS
2841 (quit (setq quit-flag t)
2842 ;; This call is to give a chance to handle quit-flag
2843 ;; in case inhibit-quit is nil.
2844 ;; Without this, it will not be handled until the next function
2845 ;; call, and that might allow it to exit thru a condition-case
2846 ;; that intends to handle the quit signal next time.
2847 (eval '(ignore nil)))))
0764e16f 2848
c2b53d7b
RS
2849(defmacro while-no-input (&rest body)
2850 "Execute BODY only as long as there's no pending input.
2851If input arrives, that ends the execution of BODY,
83047ee3
RS
2852and `while-no-input' returns t. Quitting makes it return nil.
2853If BODY finishes, `while-no-input' returns whatever value BODY produced."
c2b53d7b
RS
2854 (declare (debug t) (indent 0))
2855 (let ((catch-sym (make-symbol "input")))
2856 `(with-local-quit
2857 (catch ',catch-sym
2858 (let ((throw-on-input ',catch-sym))
790e0ef7 2859 (or (input-pending-p)
ff7d73ac 2860 (progn ,@body)))))))
c2b53d7b 2861
47ccb993
SM
2862(defmacro condition-case-no-debug (var bodyform &rest handlers)
2863 "Like `condition-case' except that it does not catch anything when debugging.
2864More specifically if `debug-on-error' is set, then it does not catch any signal."
2865 (declare (debug condition-case) (indent 2))
2866 (let ((bodysym (make-symbol "body")))
2867 `(let ((,bodysym (lambda () ,bodyform)))
2868 (if debug-on-error
2869 (funcall ,bodysym)
2870 (condition-case ,var
2871 (funcall ,bodysym)
2872 ,@handlers)))))
2873
2874(defmacro with-demoted-errors (&rest body)
2875 "Run BODY and demote any errors to simple messages.
2876If `debug-on-error' is non-nil, run BODY without catching its errors.
2877This is to be used around code which is not expected to signal an error
04bf5b65 2878but which should be robust in the unexpected case that an error is signaled."
47ccb993
SM
2879 (declare (debug t) (indent 0))
2880 (let ((err (make-symbol "err")))
2881 `(condition-case-no-debug ,err
2882 (progn ,@body)
7f0ea0ff 2883 (error (message "Error: %S" ,err) nil))))
47ccb993 2884
2ec9c94e
RS
2885(defmacro combine-after-change-calls (&rest body)
2886 "Execute BODY, but don't call the after-change functions till the end.
2887If BODY makes changes in the buffer, they are recorded
2888and the functions on `after-change-functions' are called several times
2889when BODY is finished.
31aa282e 2890The return value is the value of the last form in BODY.
2ec9c94e
RS
2891
2892If `before-change-functions' is non-nil, then calls to the after-change
2893functions can't be deferred, so in that case this macro has no effect.
2894
2895Do not alter `after-change-functions' or `before-change-functions'
2896in BODY."
d47f7515 2897 (declare (indent 0) (debug t))
2ec9c94e
RS
2898 `(unwind-protect
2899 (let ((combine-after-change-calls t))
2900 . ,body)
2901 (combine-after-change-execute)))
6a978be3
CY
2902
2903(defmacro with-case-table (table &rest body)
2904 "Execute the forms in BODY with TABLE as the current case table.
2905The value returned is the value of the last form in BODY."
2906 (declare (indent 1) (debug t))
8d6fd8d4
JPW
2907 (let ((old-case-table (make-symbol "table"))
2908 (old-buffer (make-symbol "buffer")))
2909 `(let ((,old-case-table (current-case-table))
2910 (,old-buffer (current-buffer)))
2911 (unwind-protect
2912 (progn (set-case-table ,table)
2913 ,@body)
2914 (with-current-buffer ,old-buffer
2915 (set-case-table ,old-case-table))))))
c4f484f2 2916\f
c4f484f2 2917;;; Matching and match data.
2493767e 2918
c7ca41e6
RS
2919(defvar save-match-data-internal)
2920
2921;; We use save-match-data-internal as the local variable because
2922;; that works ok in practice (people should not use that variable elsewhere).
2923;; We used to use an uninterned symbol; the compiler handles that properly
2924;; now, but it generates slower code.
9a5336ae 2925(defmacro save-match-data (&rest body)
e4d03691
JB
2926 "Execute the BODY forms, restoring the global value of the match data.
2927The value returned is the value of the last form in BODY."
64ed733a
PE
2928 ;; It is better not to use backquote here,
2929 ;; because that makes a bootstrapping problem
2930 ;; if you need to recompile all the Lisp files using interpreted code.
d47f7515 2931 (declare (indent 0) (debug t))
64ed733a
PE
2932 (list 'let
2933 '((save-match-data-internal (match-data)))
2934 (list 'unwind-protect
2935 (cons 'progn body)
d1fab151
KS
2936 ;; It is safe to free (evaporate) markers immediately here,
2937 ;; as Lisp programs should not copy from save-match-data-internal.
a0ef72df 2938 '(set-match-data save-match-data-internal 'evaporate))))
993713ce 2939
cd323f89 2940(defun match-string (num &optional string)
993713ce
SM
2941 "Return string of text matched by last search.
2942NUM specifies which parenthesized expression in the last regexp.
2943 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
2944Zero means the entire text matched by the whole regexp or whole string.
2945STRING should be given if the last search was by `string-match' on STRING."
cd323f89
SM
2946 (if (match-beginning num)
2947 (if string
2948 (substring string (match-beginning num) (match-end num))
2949 (buffer-substring (match-beginning num) (match-end num)))))
58f950b4 2950
bb760c71
RS
2951(defun match-string-no-properties (num &optional string)
2952 "Return string of text matched by last search, without text properties.
2953NUM specifies which parenthesized expression in the last regexp.
2954 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
2955Zero means the entire text matched by the whole regexp or whole string.
2956STRING should be given if the last search was by `string-match' on STRING."
2957 (if (match-beginning num)
2958 (if string
6b61353c
KH
2959 (substring-no-properties string (match-beginning num)
2960 (match-end num))
bb760c71
RS
2961 (buffer-substring-no-properties (match-beginning num)
2962 (match-end num)))))
2963
8c2e721a
JL
2964
2965(defun match-substitute-replacement (replacement
2966 &optional fixedcase literal string subexp)
2967 "Return REPLACEMENT as it will be inserted by `replace-match'.
2968In other words, all back-references in the form `\\&' and `\\N'
2969are substituted with actual strings matched by the last search.
2970Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same
2971meaning as for `replace-match'."
2972 (let ((match (match-string 0 string)))
2973 (save-match-data
2974 (set-match-data (mapcar (lambda (x)
2975 (if (numberp x)
2976 (- x (match-beginning 0))
2977 x))
2978 (match-data t)))
2979 (replace-match replacement fixedcase literal match subexp))))
2980
2981
46065dd4 2982(defun looking-back (regexp &optional limit greedy)
f30e0cd8 2983 "Return non-nil if text before point matches regular expression REGEXP.
991b32c3 2984Like `looking-at' except matches before point, and is slower.
01d16e16
RS
2985LIMIT if non-nil speeds up the search by specifying a minimum
2986starting position, to avoid checking matches that would start
2987before LIMIT.
46065dd4 2988
cde27dd2
CY
2989If GREEDY is non-nil, extend the match backwards as far as
2990possible, stopping when a single additional previous character
2991cannot be part of a match for REGEXP. When the match is
3dcde186 2992extended, its starting position is allowed to occur before
cde27dd2 2993LIMIT."
46065dd4
RS
2994 (let ((start (point))
2995 (pos
2996 (save-excursion
2997 (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)
2998 (point)))))
2999 (if (and greedy pos)
3000 (save-restriction
3001 (narrow-to-region (point-min) start)
3002 (while (and (> pos (point-min))
3003 (save-excursion
3004 (goto-char pos)
3005 (backward-char 1)
3006 (looking-at (concat "\\(?:" regexp "\\)\\'"))))
3007 (setq pos (1- pos)))
3008 (save-excursion
3009 (goto-char pos)
3010 (looking-at (concat "\\(?:" regexp "\\)\\'")))))
3011 (not (null pos))))
3012
45595a4f
RS
3013(defsubst looking-at-p (regexp)
3014 "\
3015Same as `looking-at' except this function does not change the match data."
3016 (let ((inhibit-changing-match-data t))
3017 (looking-at regexp)))
3018
3019(defsubst string-match-p (regexp string &optional start)
3020 "\
3021Same as `string-match' except this function does not change the match data."
3022 (let ((inhibit-changing-match-data t))
3023 (string-match regexp string start)))
3024
c4f484f2
RS
3025(defun subregexp-context-p (regexp pos &optional start)
3026 "Return non-nil if POS is in a normal subregexp context in REGEXP.
3027A subregexp context is one where a sub-regexp can appear.
3028A non-subregexp context is for example within brackets, or within a
3029repetition bounds operator `\\=\\{...\\}', or right after a `\\'.
3030If START is non-nil, it should be a position in REGEXP, smaller
3031than POS, and known to be in a subregexp context."
3032 ;; Here's one possible implementation, with the great benefit that it
3033 ;; reuses the regexp-matcher's own parser, so it understands all the
3034 ;; details of the syntax. A disadvantage is that it needs to match the
3035 ;; error string.
3036 (condition-case err
3037 (progn
3038 (string-match (substring regexp (or start 0) pos) "")
3039 t)
3040 (invalid-regexp
3041 (not (member (cadr err) '("Unmatched [ or [^"
3042 "Unmatched \\{"
3043 "Trailing backslash")))))
3044 ;; An alternative implementation:
3045 ;; (defconst re-context-re
3046 ;; (let* ((harmless-ch "[^\\[]")
3047 ;; (harmless-esc "\\\\[^{]")
3048 ;; (class-harmless-ch "[^][]")
3049 ;; (class-lb-harmless "[^]:]")
3050 ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?")
3051 ;; (class-lb (concat "\\[\\(" class-lb-harmless
3052 ;; "\\|" class-lb-colon-maybe-charclass "\\)"))
3053 ;; (class
3054 ;; (concat "\\[^?]?"
3055 ;; "\\(" class-harmless-ch
3056 ;; "\\|" class-lb "\\)*"
3057 ;; "\\[?]")) ; special handling for bare [ at end of re
3058 ;; (braces "\\\\{[0-9,]+\\\\}"))
3059 ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc
3060 ;; "\\|" class "\\|" braces "\\)*\\'"))
3061 ;; "Matches any prefix that corresponds to a normal subregexp context.")
3062 ;; (string-match re-context-re (substring regexp (or start 0) pos))
3063 )
3064\f
3065;;;; split-string
498535fb 3066
6a646626
JB
3067(defconst split-string-default-separators "[ \f\t\n\r\v]+"
3068 "The default value of separators for `split-string'.
3069
3070A regexp matching strings of whitespace. May be locale-dependent
3071\(as yet unimplemented). Should not match non-breaking spaces.
3072
3073Warning: binding this to a different value and using it as default is
3074likely to have undesired semantics.")
3075
3076;; The specification says that if both SEPARATORS and OMIT-NULLS are
3077;; defaulted, OMIT-NULLS should be treated as t. Simplifying the logical
3078;; expression leads to the equivalent implementation that if SEPARATORS
3079;; is defaulted, OMIT-NULLS is treated as t.
3080(defun split-string (string &optional separators omit-nulls)
203998e5 3081 "Split STRING into substrings bounded by matches for SEPARATORS.
6a646626
JB
3082
3083The beginning and end of STRING, and each match for SEPARATORS, are
3084splitting points. The substrings matching SEPARATORS are removed, and
3085the substrings between the splitting points are collected as a list,
edce3654 3086which is returned.
b222b786 3087
6a646626
JB
3088If SEPARATORS is non-nil, it should be a regular expression matching text
3089which separates, but is not part of, the substrings. If nil it defaults to
3090`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
3091OMIT-NULLS is forced to t.
3092
a478f3e1 3093If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
6a646626
JB
3094that for the default value of SEPARATORS leading and trailing whitespace
3095are effectively trimmed). If nil, all zero-length substrings are retained,
3096which correctly parses CSV format, for example.
3097
3098Note that the effect of `(split-string STRING)' is the same as
55e45419 3099`(split-string STRING split-string-default-separators t)'. In the rare
6a646626
JB
3100case that you wish to retain zero-length substrings when splitting on
3101whitespace, use `(split-string STRING split-string-default-separators)'.
b021ef18
DL
3102
3103Modifies the match data; use `save-match-data' if necessary."
6a646626
JB
3104 (let ((keep-nulls (not (if separators omit-nulls t)))
3105 (rexp (or separators split-string-default-separators))
edce3654 3106 (start 0)
b222b786 3107 notfirst
edce3654 3108 (list nil))
b222b786
RS
3109 (while (and (string-match rexp string
3110 (if (and notfirst
3111 (= start (match-beginning 0))
3112 (< start (length string)))
3113 (1+ start) start))
6a646626 3114 (< start (length string)))
b222b786 3115 (setq notfirst t)
6a646626 3116 (if (or keep-nulls (< start (match-beginning 0)))
edce3654
RS
3117 (setq list
3118 (cons (substring string start (match-beginning 0))
3119 list)))
3120 (setq start (match-end 0)))
6a646626 3121 (if (or keep-nulls (< start (length string)))
edce3654
RS
3122 (setq list
3123 (cons (substring string start)
3124 list)))
3125 (nreverse list)))
0b93ff3a 3126
e80b3849 3127(defun combine-and-quote-strings (strings &optional separator)
0b93ff3a
NR
3128 "Concatenate the STRINGS, adding the SEPARATOR (default \" \").
3129This tries to quote the strings to avoid ambiguity such that
e80b3849 3130 (split-string-and-unquote (combine-and-quote-strings strs)) == strs
0b93ff3a 3131Only some SEPARATORs will work properly."
9f2bd2e7
SM
3132 (let* ((sep (or separator " "))
3133 (re (concat "[\\\"]" "\\|" (regexp-quote sep))))
0b93ff3a
NR
3134 (mapconcat
3135 (lambda (str)
9f2bd2e7 3136 (if (string-match re str)
0b93ff3a
NR
3137 (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"")
3138 str))
3139 strings sep)))
3140
e80b3849 3141(defun split-string-and-unquote (string &optional separator)
0b93ff3a 3142 "Split the STRING into a list of strings.
e80b3849
RS
3143It understands Emacs Lisp quoting within STRING, such that
3144 (split-string-and-unquote (combine-and-quote-strings strs)) == strs
0b93ff3a
NR
3145The SEPARATOR regexp defaults to \"\\s-+\"."
3146 (let ((sep (or separator "\\s-+"))
d551d20d 3147 (i (string-match "\"" string)))
e80b3849
RS
3148 (if (null i)
3149 (split-string string sep t) ; no quoting: easy
0b93ff3a
NR
3150 (append (unless (eq i 0) (split-string (substring string 0 i) sep t))
3151 (let ((rfs (read-from-string string i)))
3152 (cons (car rfs)
e80b3849
RS
3153 (split-string-and-unquote (substring string (cdr rfs))
3154 sep)))))))
0b93ff3a 3155
c4f484f2
RS
3156\f
3157;;;; Replacement in strings.
1ccaea52
AI
3158
3159(defun subst-char-in-string (fromchar tochar string &optional inplace)
3160 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
3161Unless optional argument INPLACE is non-nil, return a new string."
e6e71807
SM
3162 (let ((i (length string))
3163 (newstr (if inplace string (copy-sequence string))))
3164 (while (> i 0)
3165 (setq i (1- i))
3166 (if (eq (aref newstr i) fromchar)
3167 (aset newstr i tochar)))
3168 newstr))
b021ef18 3169
1697159c 3170(defun replace-regexp-in-string (regexp rep string &optional
c8227332 3171 fixedcase literal subexp start)
b021ef18
DL
3172 "Replace all matches for REGEXP with REP in STRING.
3173
3174Return a new string containing the replacements.
3175
3176Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the
3177arguments with the same names of function `replace-match'. If START
3178is non-nil, start replacements at that index in STRING.
3179
3180REP is either a string used as the NEWTEXT arg of `replace-match' or a
23bb94bb
RS
3181function. If it is a function, it is called with the actual text of each
3182match, and its value is used as the replacement text. When REP is called,
3183the match-data are the result of matching REGEXP against a substring
3184of STRING.
b021ef18 3185
1697159c
DL
3186To replace only the first match (if any), make REGEXP match up to \\'
3187and replace a sub-expression, e.g.
c9bcb507 3188 (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\'\" \"bar\" \" foo foo\" nil nil 1)
1697159c
DL
3189 => \" bar foo\"
3190"
b021ef18
DL
3191
3192 ;; To avoid excessive consing from multiple matches in long strings,
3193 ;; don't just call `replace-match' continually. Walk down the
3194 ;; string looking for matches of REGEXP and building up a (reversed)
3195 ;; list MATCHES. This comprises segments of STRING which weren't
3196 ;; matched interspersed with replacements for segments that were.
08b1f8a1 3197 ;; [For a `large' number of replacements it's more efficient to
b021ef18
DL
3198 ;; operate in a temporary buffer; we can't tell from the function's
3199 ;; args whether to choose the buffer-based implementation, though it
3200 ;; might be reasonable to do so for long enough STRING.]
3201 (let ((l (length string))
3202 (start (or start 0))
3203 matches str mb me)
3204 (save-match-data
3205 (while (and (< start l) (string-match regexp string start))
3206 (setq mb (match-beginning 0)
3207 me (match-end 0))
a9853251
SM
3208 ;; If we matched the empty string, make sure we advance by one char
3209 (when (= me mb) (setq me (min l (1+ mb))))
3210 ;; Generate a replacement for the matched substring.
3211 ;; Operate only on the substring to minimize string consing.
3212 ;; Set up match data for the substring for replacement;
3213 ;; presumably this is likely to be faster than munging the
3214 ;; match data directly in Lisp.
3215 (string-match regexp (setq str (substring string mb me)))
3216 (setq matches
3217 (cons (replace-match (if (stringp rep)
3218 rep
3219 (funcall rep (match-string 0 str)))
3220 fixedcase literal str subexp)
c8227332 3221 (cons (substring string start mb) ; unmatched prefix
a9853251
SM
3222 matches)))
3223 (setq start me))
b021ef18
DL
3224 ;; Reconstruct a string from the pieces.
3225 (setq matches (cons (substring string start l) matches)) ; leftover
3226 (apply #'concat (nreverse matches)))))
a7ed4c2a 3227\f
cb190d7d
SM
3228(defun string-prefix-p (str1 str2 &optional ignore-case)
3229 "Return non-nil if STR1 is a prefix of STR2.
3230If IGNORE-CASE is non-nil, the comparison is done without paying attention
3231to case differences."
3232 (eq t (compare-strings str1 nil nil
3233 str2 0 (length str1) ignore-case)))
3234\f
c4f484f2 3235;;;; invisibility specs
df8e73e1 3236
c4f484f2
RS
3237(defun add-to-invisibility-spec (element)
3238 "Add ELEMENT to `buffer-invisibility-spec'.
3239See documentation for `buffer-invisibility-spec' for the kind of elements
3240that can be added."
3241 (if (eq buffer-invisibility-spec t)
3242 (setq buffer-invisibility-spec (list t)))
3243 (setq buffer-invisibility-spec
3244 (cons element buffer-invisibility-spec)))
3245
3246(defun remove-from-invisibility-spec (element)
3247 "Remove ELEMENT from `buffer-invisibility-spec'."
3248 (if (consp buffer-invisibility-spec)
c8227332
VJL
3249 (setq buffer-invisibility-spec
3250 (delete element buffer-invisibility-spec))))
a7ed4c2a 3251\f
c4f484f2
RS
3252;;;; Syntax tables.
3253
3254(defmacro with-syntax-table (table &rest body)
3255 "Evaluate BODY with syntax table of current buffer set to TABLE.
3256The syntax table of the current buffer is saved, BODY is evaluated, and the
3257saved table is restored, even in case of an abnormal exit.
3258Value is what BODY returns."
f291fe60 3259 (declare (debug t) (indent 1))
c4f484f2
RS
3260 (let ((old-table (make-symbol "table"))
3261 (old-buffer (make-symbol "buffer")))
3262 `(let ((,old-table (syntax-table))
3263 (,old-buffer (current-buffer)))
3264 (unwind-protect
3265 (progn
3266 (set-syntax-table ,table)
3267 ,@body)
3268 (save-current-buffer
3269 (set-buffer ,old-buffer)
3270 (set-syntax-table ,old-table))))))
8af7df60 3271
297d863b 3272(defun make-syntax-table (&optional oldtable)
984f718a 3273 "Return a new syntax table.
0764e16f
SM
3274Create a syntax table which inherits from OLDTABLE (if non-nil) or
3275from `standard-syntax-table' otherwise."
3276 (let ((table (make-char-table 'syntax-table nil)))
3277 (set-char-table-parent table (or oldtable (standard-syntax-table)))
3278 table))
31aa282e 3279
e9f13a95 3280(defun syntax-after (pos)
9d1ffd5a
EZ
3281 "Return the raw syntax of the char after POS.
3282If POS is outside the buffer's accessible portion, return nil."
e9f13a95 3283 (unless (or (< pos (point-min)) (>= pos (point-max)))
d8ac3d27
SM
3284 (let ((st (if parse-sexp-lookup-properties
3285 (get-char-property pos 'syntax-table))))
3286 (if (consp st) st
3287 (aref (or st (syntax-table)) (char-after pos))))))
e9f13a95 3288
cdd8dc28 3289(defun syntax-class (syntax)
9d1ffd5a
EZ
3290 "Return the syntax class part of the syntax descriptor SYNTAX.
3291If SYNTAX is nil, return nil."
3292 (and syntax (logand (car syntax) 65535)))
2493767e 3293\f
c4f484f2 3294;;;; Text clones
a13fe4c5
SM
3295
3296(defun text-clone-maintain (ol1 after beg end &optional len)
3297 "Propagate the changes made under the overlay OL1 to the other clones.
3298This is used on the `modification-hooks' property of text clones."
3299 (when (and after (not undo-in-progress) (overlay-start ol1))
3300 (let ((margin (if (overlay-get ol1 'text-clone-spreadp) 1 0)))
3301 (setq beg (max beg (+ (overlay-start ol1) margin)))
3302 (setq end (min end (- (overlay-end ol1) margin)))
3303 (when (<= beg end)
3304 (save-excursion
3305 (when (overlay-get ol1 'text-clone-syntax)
3306 ;; Check content of the clone's text.
3307 (let ((cbeg (+ (overlay-start ol1) margin))
3308 (cend (- (overlay-end ol1) margin)))
3309 (goto-char cbeg)
3310 (save-match-data
3311 (if (not (re-search-forward
3312 (overlay-get ol1 'text-clone-syntax) cend t))
3313 ;; Mark the overlay for deletion.
3314 (overlay-put ol1 'text-clones nil)
3315 (when (< (match-end 0) cend)
3316 ;; Shrink the clone at its end.
3317 (setq end (min end (match-end 0)))
3318 (move-overlay ol1 (overlay-start ol1)
3319 (+ (match-end 0) margin)))
3320 (when (> (match-beginning 0) cbeg)
3321 ;; Shrink the clone at its beginning.
3322 (setq beg (max (match-beginning 0) beg))
3323 (move-overlay ol1 (- (match-beginning 0) margin)
3324 (overlay-end ol1)))))))
3325 ;; Now go ahead and update the clones.
3326 (let ((head (- beg (overlay-start ol1)))
3327 (tail (- (overlay-end ol1) end))
3328 (str (buffer-substring beg end))
3329 (nothing-left t)
3330 (inhibit-modification-hooks t))
3331 (dolist (ol2 (overlay-get ol1 'text-clones))
3332 (let ((oe (overlay-end ol2)))
3333 (unless (or (eq ol1 ol2) (null oe))
3334 (setq nothing-left nil)
3335 (let ((mod-beg (+ (overlay-start ol2) head)))
3336 ;;(overlay-put ol2 'modification-hooks nil)
3337 (goto-char (- (overlay-end ol2) tail))
3338 (unless (> mod-beg (point))
3339 (save-excursion (insert str))
3340 (delete-region mod-beg (point)))
3341 ;;(overlay-put ol2 'modification-hooks '(text-clone-maintain))
3342 ))))
3343 (if nothing-left (delete-overlay ol1))))))))
3344
3345(defun text-clone-create (start end &optional spreadp syntax)
3346 "Create a text clone of START...END at point.
3347Text clones are chunks of text that are automatically kept identical:
3348changes done to one of the clones will be immediately propagated to the other.
3349
3350The buffer's content at point is assumed to be already identical to
3351the one between START and END.
3352If SYNTAX is provided it's a regexp that describes the possible text of
3353the clones; the clone will be shrunk or killed if necessary to ensure that
3354its text matches the regexp.
3355If SPREADP is non-nil it indicates that text inserted before/after the
3356clone should be incorporated in the clone."
3357 ;; To deal with SPREADP we can either use an overlay with `nil t' along
3358 ;; with insert-(behind|in-front-of)-hooks or use a slightly larger overlay
3359 ;; (with a one-char margin at each end) with `t nil'.
3360 ;; We opted for a larger overlay because it behaves better in the case
3361 ;; where the clone is reduced to the empty string (we want the overlay to
3362 ;; stay when the clone's content is the empty string and we want to use
3363 ;; `evaporate' to make sure those overlays get deleted when needed).
264ef586 3364 ;;
a13fe4c5
SM
3365 (let* ((pt-end (+ (point) (- end start)))
3366 (start-margin (if (or (not spreadp) (bobp) (<= start (point-min)))
3367 0 1))
3368 (end-margin (if (or (not spreadp)
3369 (>= pt-end (point-max))
3370 (>= start (point-max)))
3371 0 1))
3372 (ol1 (make-overlay (- start start-margin) (+ end end-margin) nil t))
3373 (ol2 (make-overlay (- (point) start-margin) (+ pt-end end-margin) nil t))
3374 (dups (list ol1 ol2)))
3375 (overlay-put ol1 'modification-hooks '(text-clone-maintain))
3376 (when spreadp (overlay-put ol1 'text-clone-spreadp t))
3377 (when syntax (overlay-put ol1 'text-clone-syntax syntax))
3378 ;;(overlay-put ol1 'face 'underline)
3379 (overlay-put ol1 'evaporate t)
3380 (overlay-put ol1 'text-clones dups)
264ef586 3381 ;;
a13fe4c5
SM
3382 (overlay-put ol2 'modification-hooks '(text-clone-maintain))
3383 (when spreadp (overlay-put ol2 'text-clone-spreadp t))
3384 (when syntax (overlay-put ol2 'text-clone-syntax syntax))
3385 ;;(overlay-put ol2 'face 'underline)
3386 (overlay-put ol2 'evaporate t)
3387 (overlay-put ol2 'text-clones dups)))
c4f484f2
RS
3388\f
3389;;;; Mail user agents.
27c079eb 3390
c4f484f2
RS
3391;; Here we include just enough for other packages to be able
3392;; to define them.
324cd947 3393
27c079eb
SM
3394(defun define-mail-user-agent (symbol composefunc sendfunc
3395 &optional abortfunc hookvar)
3396 "Define a symbol to identify a mail-sending package for `mail-user-agent'.
3397
3398SYMBOL can be any Lisp symbol. Its function definition and/or
3399value as a variable do not matter for this usage; we use only certain
3400properties on its property list, to encode the rest of the arguments.
3401
3402COMPOSEFUNC is program callable function that composes an outgoing
3403mail message buffer. This function should set up the basics of the
3404buffer without requiring user interaction. It should populate the
3405standard mail headers, leaving the `to:' and `subject:' headers blank
3406by default.
3407
3408COMPOSEFUNC should accept several optional arguments--the same
3409arguments that `compose-mail' takes. See that function's documentation.
3410
3411SENDFUNC is the command a user would run to send the message.
3412
3413Optional ABORTFUNC is the command a user would run to abort the
3414message. For mail packages that don't have a separate abort function,
3415this can be `kill-buffer' (the equivalent of omitting this argument).
3416
3417Optional HOOKVAR is a hook variable that gets run before the message
3418is actually sent. Callers that use the `mail-user-agent' may
3419install a hook function temporarily on this hook variable.
3420If HOOKVAR is nil, `mail-send-hook' is used.
3421
3422The properties used on SYMBOL are `composefunc', `sendfunc',
3423`abortfunc', and `hookvar'."
3424 (put symbol 'composefunc composefunc)
3425 (put symbol 'sendfunc sendfunc)
3426 (put symbol 'abortfunc (or abortfunc 'kill-buffer))
3427 (put symbol 'hookvar (or hookvar 'mail-send-hook)))
c4f484f2
RS
3428\f
3429;;;; Progress reporters.
b4329caa
EZ
3430
3431;; Progress reporter has the following structure:
3432;;
3433;; (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME
3434;; MIN-VALUE
3435;; MAX-VALUE
3436;; MESSAGE
3437;; MIN-CHANGE
3438;; MIN-TIME])
3439;;
3440;; This weirdeness is for optimization reasons: we want
3441;; `progress-reporter-update' to be as fast as possible, so
3442;; `(car reporter)' is better than `(aref reporter 0)'.
3443;;
3444;; NEXT-UPDATE-TIME is a float. While `float-time' loses a couple
3445;; digits of precision, it doesn't really matter here. On the other
3446;; hand, it greatly simplifies the code.
3447
9326ba26 3448(defsubst progress-reporter-update (reporter &optional value)
c85152fc 3449 "Report progress of an operation in the echo area.
9326ba26
CY
3450REPORTER should be the result of a call to `make-progress-reporter'.
3451
3452If REPORTER is a numerical progress reporter---i.e. if it was
3453 made using non-nil MIN-VALUE and MAX-VALUE arguments to
3454 `make-progress-reporter'---then VALUE should be a number between
3455 MIN-VALUE and MAX-VALUE.
c85152fc 3456
9326ba26 3457If REPORTER is a non-numerical reporter, VALUE should be nil.
b4329caa 3458
9326ba26
CY
3459This function is relatively inexpensive. If the change since
3460last update is too small or insufficient time has passed, it does
3461nothing."
3462 (when (or (not (numberp value)) ; For pulsing reporter
3463 (>= value (car reporter))) ; For numerical reporter
3464 (progress-reporter-do-update reporter value)))
3465
3466(defun make-progress-reporter (message &optional min-value max-value
3467 current-value min-change min-time)
3468 "Return progress reporter object for use with `progress-reporter-update'.
3469
3470MESSAGE is shown in the echo area, with a status indicator
3471appended to the end. When you call `progress-reporter-done', the
3472word \"done\" is printed after the MESSAGE. You can change the
3473MESSAGE of an existing progress reporter by calling
3474`progress-reporter-force-update'.
3475
3476MIN-VALUE and MAX-VALUE, if non-nil, are starting (0% complete)
3477and final (100% complete) states of operation; the latter should
3478be larger. In this case, the status message shows the percentage
3479progress.
3480
3481If MIN-VALUE and/or MAX-VALUE is omitted or nil, the status
3482message shows a \"spinning\", non-numeric indicator.
3483
3484Optional CURRENT-VALUE is the initial progress; the default is
3485MIN-VALUE.
3486Optional MIN-CHANGE is the minimal change in percents to report;
3487the default is 1%.
3488CURRENT-VALUE and MIN-CHANGE do not have any effect if MIN-VALUE
3489and/or MAX-VALUE are nil.
3490
3491Optional MIN-TIME specifies the minimum interval time between
3492echo area updates (default is 0.2 seconds.) If the function
3493`float-time' is not present, time is not tracked at all. If the
3494OS is not capable of measuring fractions of seconds, this
3495parameter is effectively rounded up."
b4329caa
EZ
3496 (unless min-time
3497 (setq min-time 0.2))
3498 (let ((reporter
9326ba26
CY
3499 ;; Force a call to `message' now
3500 (cons (or min-value 0)
b4329caa
EZ
3501 (vector (if (and (fboundp 'float-time)
3502 (>= min-time 0.02))
3503 (float-time) nil)
3504 min-value
3505 max-value
3506 message
3507 (if min-change (max (min min-change 50) 1) 1)
3508 min-time))))
3509 (progress-reporter-update reporter (or current-value min-value))
3510 reporter))
3511
9326ba26 3512(defun progress-reporter-force-update (reporter &optional value new-message)
b4329caa
EZ
3513 "Report progress of an operation in the echo area unconditionally.
3514
9326ba26
CY
3515The first two arguments are the same as in `progress-reporter-update'.
3516NEW-MESSAGE, if non-nil, sets a new message for the reporter."
b4329caa
EZ
3517 (let ((parameters (cdr reporter)))
3518 (when new-message
3519 (aset parameters 3 new-message))
3520 (when (aref parameters 0)
3521 (aset parameters 0 (float-time)))
3522 (progress-reporter-do-update reporter value)))
3523
9326ba26
CY
3524(defvar progress-reporter--pulse-characters ["-" "\\" "|" "/"]
3525 "Characters to use for pulsing progress reporters.")
3526
b4329caa
EZ
3527(defun progress-reporter-do-update (reporter value)
3528 (let* ((parameters (cdr reporter))
9326ba26 3529 (update-time (aref parameters 0))
b4329caa
EZ
3530 (min-value (aref parameters 1))
3531 (max-value (aref parameters 2))
9326ba26 3532 (text (aref parameters 3))
b4329caa
EZ
3533 (current-time (float-time))
3534 (enough-time-passed
3535 ;; See if enough time has passed since the last update.
3536 (or (not update-time)
3537 (when (>= current-time update-time)
3538 ;; Calculate time for the next update
3539 (aset parameters 0 (+ update-time (aref parameters 5)))))))
9326ba26
CY
3540 (cond ((and min-value max-value)
3541 ;; Numerical indicator
3542 (let* ((one-percent (/ (- max-value min-value) 100.0))
3543 (percentage (if (= max-value min-value)
3544 0
3545 (truncate (/ (- value min-value)
3546 one-percent)))))
3547 ;; Calculate NEXT-UPDATE-VALUE. If we are not printing
3548 ;; message because not enough time has passed, use 1
3549 ;; instead of MIN-CHANGE. This makes delays between echo
3550 ;; area updates closer to MIN-TIME.
3551 (setcar reporter
3552 (min (+ min-value (* (+ percentage
3553 (if enough-time-passed
3554 ;; MIN-CHANGE
3555 (aref parameters 4)
3556 1))
3557 one-percent))
3558 max-value))
3559 (when (integerp value)
3560 (setcar reporter (ceiling (car reporter))))
3561 ;; Only print message if enough time has passed
3562 (when enough-time-passed
3563 (if (> percentage 0)
3564 (message "%s%d%%" text percentage)
3565 (message "%s" text)))))
3566 ;; Pulsing indicator
3567 (enough-time-passed
3568 (let ((index (mod (1+ (car reporter)) 4))
3569 (message-log-max nil))
3570 (setcar reporter index)
3571 (message "%s %s"
3572 text
3573 (aref progress-reporter--pulse-characters
3574 index)))))))
b4329caa
EZ
3575
3576(defun progress-reporter-done (reporter)
3577 "Print reporter's message followed by word \"done\" in echo area."
3578 (message "%sdone" (aref (cdr reporter) 3)))
3579
aa56124a
SM
3580(defmacro dotimes-with-progress-reporter (spec message &rest body)
3581 "Loop a certain number of times and report progress in the echo area.
3582Evaluate BODY with VAR bound to successive integers running from
35830, inclusive, to COUNT, exclusive. Then evaluate RESULT to get
3584the return value (nil if RESULT is omitted).
3585
3586At each iteration MESSAGE followed by progress percentage is
3587printed in the echo area. After the loop is finished, MESSAGE
3588followed by word \"done\" is printed. This macro is a
3589convenience wrapper around `make-progress-reporter' and friends.
3590
3591\(fn (VAR COUNT [RESULT]) MESSAGE BODY...)"
3592 (declare (indent 2) (debug ((symbolp form &optional form) form body)))
3593 (let ((temp (make-symbol "--dotimes-temp--"))
3594 (temp2 (make-symbol "--dotimes-temp2--"))
3595 (start 0)
3596 (end (nth 1 spec)))
3597 `(let ((,temp ,end)
3598 (,(car spec) ,start)
3599 (,temp2 (make-progress-reporter ,message ,start ,end)))
3600 (while (< ,(car spec) ,temp)
3601 ,@body
3602 (progress-reporter-update ,temp2
3603 (setq ,(car spec) (1+ ,(car spec)))))
3604 (progress-reporter-done ,temp2)
3605 nil ,@(cdr (cdr spec)))))
ca548b00 3606
e9454757 3607\f
c4f484f2 3608;;;; Comparing version strings.
e9454757 3609
2f7f4bee 3610(defconst version-separator "."
b29f5b7b 3611 "Specify the string used to separate the version elements.
e9454757
VJL
3612
3613Usually the separator is \".\", but it can be any other string.")
3614
3615
2f7f4bee 3616(defconst version-regexp-alist
b29f5b7b
VJL
3617 '(("^[-_+ ]?alpha$" . -3)
3618 ("^[-_+]$" . -3) ; treat "1.2.3-20050920" and "1.2-3" as alpha releases
3619 ("^[-_+ ]cvs$" . -3) ; treat "1.2.3-CVS" as alpha release
3620 ("^[-_+ ]?beta$" . -2)
e2046ecf 3621 ("^[-_+ ]?\\(pre\\|rcc\\)$" . -1))
b29f5b7b 3622 "Specify association between non-numeric version and its priority.
e9454757
VJL
3623
3624This association is used to handle version string like \"1.0pre2\",
3625\"0.9alpha1\", etc. It's used by `version-to-list' (which see) to convert the
94785022 3626non-numeric part of a version string to an integer. For example:
e9454757
VJL
3627
3628 String Version Integer List Version
3629 \"1.0pre2\" (1 0 -1 2)
3630 \"1.0PRE2\" (1 0 -1 2)
3631 \"22.8beta3\" (22 8 -2 3)
c71abb54 3632 \"22.8 Beta3\" (22 8 -2 3)
e9454757
VJL
3633 \"0.9alpha1\" (0 9 -3 1)
3634 \"0.9AlphA1\" (0 9 -3 1)
c71abb54 3635 \"0.9 alpha\" (0 9 -3)
e9454757
VJL
3636
3637Each element has the following form:
3638
3639 (REGEXP . PRIORITY)
3640
3641Where:
3642
3643REGEXP regexp used to match non-numeric part of a version string.
94785022 3644 It should begin with the `^' anchor and end with a `$' to
d74a5c91
EZ
3645 prevent false hits. Letter-case is ignored while matching
3646 REGEXP.
e9454757 3647
94785022 3648PRIORITY a negative integer specifying non-numeric priority of REGEXP.")
e9454757
VJL
3649
3650
3651(defun version-to-list (ver)
94785022 3652 "Convert version string VER into a list of integers.
e9454757
VJL
3653
3654The version syntax is given by the following EBNF:
3655
3656 VERSION ::= NUMBER ( SEPARATOR NUMBER )*.
3657
3658 NUMBER ::= (0|1|2|3|4|5|6|7|8|9)+.
3659
3660 SEPARATOR ::= `version-separator' (which see)
3661 | `version-regexp-alist' (which see).
3662
d74a5c91
EZ
3663The NUMBER part is optional if SEPARATOR is a match for an element
3664in `version-regexp-alist'.
3665
94785022 3666Examples of valid version syntax:
e9454757 3667
d74a5c91 3668 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1 6.9.30Beta
e9454757 3669
94785022 3670Examples of invalid version syntax:
e9454757
VJL
3671
3672 1.0prepre2 1.0..7.5 22.8X3 alpha3.2 .5
3673
94785022 3674Examples of version conversion:
e9454757 3675
94785022 3676 Version String Version as a List of Integers
e9454757
VJL
3677 \"1.0.7.5\" (1 0 7 5)
3678 \"1.0pre2\" (1 0 -1 2)
3679 \"1.0PRE2\" (1 0 -1 2)
3680 \"22.8beta3\" (22 8 -2 3)
3681 \"22.8Beta3\" (22 8 -2 3)
3682 \"0.9alpha1\" (0 9 -3 1)
3683 \"0.9AlphA1\" (0 9 -3 1)
3684 \"0.9alpha\" (0 9 -3)
3685
3686See documentation for `version-separator' and `version-regexp-alist'."
c71abb54 3687 (or (and (stringp ver) (> (length ver) 0))
e9454757 3688 (error "Invalid version string: '%s'" ver))
c71abb54
KS
3689 ;; Change .x.y to 0.x.y
3690 (if (and (>= (length ver) (length version-separator))
3691 (string-equal (substring ver 0 (length version-separator))
c8227332 3692 version-separator))
c71abb54 3693 (setq ver (concat "0" ver)))
e9454757
VJL
3694 (save-match-data
3695 (let ((i 0)
d74a5c91 3696 (case-fold-search t) ; ignore case in matching
e9454757
VJL
3697 lst s al)
3698 (while (and (setq s (string-match "[0-9]+" ver i))
3699 (= s i))
3700 ;; handle numeric part
3701 (setq lst (cons (string-to-number (substring ver i (match-end 0)))
3702 lst)
3703 i (match-end 0))
3704 ;; handle non-numeric part
3705 (when (and (setq s (string-match "[^0-9]+" ver i))
3706 (= s i))
3707 (setq s (substring ver i (match-end 0))
3708 i (match-end 0))
3709 ;; handle alpha, beta, pre, etc. separator
3710 (unless (string= s version-separator)
3711 (setq al version-regexp-alist)
3712 (while (and al (not (string-match (caar al) s)))
3713 (setq al (cdr al)))
e2046ecf
CY
3714 (cond (al
3715 (push (cdar al) lst))
b29f5b7b 3716 ;; Convert 22.3a to 22.3.1, 22.3b to 22.3.2, etc.
e2046ecf
CY
3717 ((string-match "^[-_+ ]?\\([a-zA-Z]\\)$" s)
3718 (push (- (aref (downcase (match-string 1 s)) 0) ?a -1)
3719 lst))
3720 (t (error "Invalid version syntax: '%s'" ver))))))
e9454757
VJL
3721 (if (null lst)
3722 (error "Invalid version syntax: '%s'" ver)
3723 (nreverse lst)))))
3724
3725
ca548b00 3726(defun version-list-< (l1 l2)
94785022 3727 "Return t if L1, a list specification of a version, is lower than L2.
e9454757 3728
94785022
EZ
3729Note that a version specified by the list (1) is equal to (1 0),
3730\(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant.
3731Also, a version given by the list (1) is higher than (1 -1), which in
3732turn is higher than (1 -2), which is higher than (1 -3)."
e9454757
VJL
3733 (while (and l1 l2 (= (car l1) (car l2)))
3734 (setq l1 (cdr l1)
3735 l2 (cdr l2)))
3736 (cond
3737 ;; l1 not null and l2 not null
3738 ((and l1 l2) (< (car l1) (car l2)))
3739 ;; l1 null and l2 null ==> l1 length = l2 length
3740 ((and (null l1) (null l2)) nil)
3741 ;; l1 not null and l2 null ==> l1 length > l2 length
ca548b00 3742 (l1 (< (version-list-not-zero l1) 0))
e9454757 3743 ;; l1 null and l2 not null ==> l2 length > l1 length
ca548b00 3744 (t (< 0 (version-list-not-zero l2)))))
e9454757
VJL
3745
3746
ca548b00 3747(defun version-list-= (l1 l2)
94785022 3748 "Return t if L1, a list specification of a version, is equal to L2.
e9454757 3749
94785022
EZ
3750Note that a version specified by the list (1) is equal to (1 0),
3751\(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant.
3752Also, a version given by the list (1) is higher than (1 -1), which in
3753turn is higher than (1 -2), which is higher than (1 -3)."
e9454757
VJL
3754 (while (and l1 l2 (= (car l1) (car l2)))
3755 (setq l1 (cdr l1)
3756 l2 (cdr l2)))
3757 (cond
3758 ;; l1 not null and l2 not null
3759 ((and l1 l2) nil)
3760 ;; l1 null and l2 null ==> l1 length = l2 length
3761 ((and (null l1) (null l2)))
3762 ;; l1 not null and l2 null ==> l1 length > l2 length
ca548b00 3763 (l1 (zerop (version-list-not-zero l1)))
e9454757 3764 ;; l1 null and l2 not null ==> l2 length > l1 length
ca548b00 3765 (t (zerop (version-list-not-zero l2)))))
e9454757
VJL
3766
3767
ca548b00 3768(defun version-list-<= (l1 l2)
94785022 3769 "Return t if L1, a list specification of a version, is lower or equal to L2.
e9454757
VJL
3770
3771Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
b29f5b7b 3772etc. That is, the trailing zeroes are insignificant. Also, integer
e9454757
VJL
3773list (1) is greater than (1 -1) which is greater than (1 -2)
3774which is greater than (1 -3)."
3775 (while (and l1 l2 (= (car l1) (car l2)))
3776 (setq l1 (cdr l1)
3777 l2 (cdr l2)))
3778 (cond
3779 ;; l1 not null and l2 not null
3780 ((and l1 l2) (< (car l1) (car l2)))
3781 ;; l1 null and l2 null ==> l1 length = l2 length
3782 ((and (null l1) (null l2)))
3783 ;; l1 not null and l2 null ==> l1 length > l2 length
ca548b00 3784 (l1 (<= (version-list-not-zero l1) 0))
e9454757 3785 ;; l1 null and l2 not null ==> l2 length > l1 length
ca548b00 3786 (t (<= 0 (version-list-not-zero l2)))))
e9454757 3787
ca548b00 3788(defun version-list-not-zero (lst)
94785022 3789 "Return the first non-zero element of LST, which is a list of integers.
e9454757 3790
94785022 3791If all LST elements are zeros or LST is nil, return zero."
ca548b00
KS
3792 (while (and lst (zerop (car lst)))
3793 (setq lst (cdr lst)))
3794 (if lst
3795 (car lst)
3796 ;; there is no element different of zero
3797 0))
e9454757
VJL
3798
3799
3800(defun version< (v1 v2)
94785022 3801 "Return t if version V1 is lower (older) than V2.
e9454757
VJL
3802
3803Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
94785022
EZ
3804etc. That is, the trailing \".0\"s are insignificant. Also, version
3805string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
3806which is higher than \"1alpha\"."
ca548b00 3807 (version-list-< (version-to-list v1) (version-to-list v2)))
e9454757
VJL
3808
3809
3810(defun version<= (v1 v2)
94785022 3811 "Return t if version V1 is lower (older) than or equal to V2.
e9454757
VJL
3812
3813Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
b29f5b7b 3814etc. That is, the trailing \".0\"s are insignificant. Also, version
94785022
EZ
3815string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
3816which is higher than \"1alpha\"."
ca548b00 3817 (version-list-<= (version-to-list v1) (version-to-list v2)))
e9454757 3818
ca548b00
KS
3819(defun version= (v1 v2)
3820 "Return t if version V1 is equal to V2.
e9454757 3821
ca548b00 3822Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
b29f5b7b 3823etc. That is, the trailing \".0\"s are insignificant. Also, version
94785022
EZ
3824string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
3825which is higher than \"1alpha\"."
ca548b00 3826 (version-list-= (version-to-list v1) (version-to-list v2)))
e9454757 3827
18d433a7
CY
3828\f
3829;;; Misc.
a3c20c83
DN
3830(defconst menu-bar-separator '("--")
3831 "Separator for menus.")
18d433a7
CY
3832
3833;; The following statement ought to be in print.c, but `provide' can't
3834;; be used there.
5612fd08 3835;; http://lists.gnu.org/archive/html/emacs-devel/2009-08/msg00236.html
18d433a7
CY
3836(when (hash-table-p (car (read-from-string
3837 (prin1-to-string (make-hash-table)))))
3838 (provide 'hashtable-print-readable))
3839
630cc463 3840;;; subr.el ends here