;;; subr.el --- basic lisp subroutines for Emacs
;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
-;; 2004 Free Software Foundation, Inc.
+;; 2004, 2005, 2006 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(cons arguments custom-declare-variable-list)))
\f
-(defun macro-declaration-function (macro decl)
- "Process a declaration found in a macro definition.
-This is set as the value of the variable `macro-declaration-function'.
-MACRO is the name of the macro being defined.
-DECL is a list `(declare ...)' containing the declarations.
-The return value of this function is not used."
- ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons.
- (let (d)
- ;; Ignore the first element of `decl' (it's always `declare').
- (while (setq decl (cdr decl))
- (setq d (car decl))
- (cond ((and (consp d) (eq (car d) 'indent))
- (put macro 'lisp-indent-function (car (cdr d))))
- ((and (consp d) (eq (car d) 'debug))
- (put macro 'edebug-form-spec (car (cdr d))))
- (t
- (message "Unknown declaration %s" d))))))
-
-(setq macro-declaration-function 'macro-declaration-function)
-
-\f
-;;;; Lisp language features.
+;;;; Basic Lisp macros.
(defalias 'not 'null)
(defmacro noreturn (form)
- "Evaluates FORM, with the expectation that the evaluation will signal an error
-instead of returning to its caller. If FORM does return, an error is
-signalled."
+ "Evaluate FORM, expecting it not to return.
+If FORM does return, signal an error."
`(prog1 ,form
(error "Form marked with `noreturn' did return")))
(defmacro 1value (form)
- "Evaluates FORM, with the expectation that all the same value will be returned
-from all evaluations of FORM. This is the global do-nothing
-version of `1value'. There is also `testcover-1value' that
-complains if FORM ever does return differing values."
+ "Evaluate FORM, expecting a constant return value.
+This is the global do-nothing version. There is also `testcover-1value'
+that complains if FORM ever does return differing values."
form)
(defmacro lambda (&rest cdr)
self-quoting; the result of evaluating the lambda expression is the
expression itself. The lambda expression may then be treated as a
function, i.e., stored as the function value of a symbol, passed to
-funcall or mapcar, etc.
+`funcall' or `mapcar', etc.
ARGS should take the same form as an argument list for a `defun'.
DOCSTRING is an optional documentation string.
Treated as a declaration when used at the right place in a
`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
nil)
+\f
+;;;; Basic Lisp functions.
+
+(defun ignore (&rest ignore)
+ "Do nothing and return nil.
+This function accepts any number of arguments, but ignores them."
+ (interactive)
+ nil)
+
+(defun error (&rest args)
+ "Signal an error, making error message by passing all args to `format'.
+In Emacs, the convention is that error messages start with a capital
+letter but *do not* end with a period. Please follow this convention
+for the sake of consistency."
+ (while t
+ (signal 'error (list (apply 'format args)))))
+
+;; We put this here instead of in frame.el so that it's defined even on
+;; systems where frame.el isn't loaded.
+(defun frame-configuration-p (object)
+ "Return non-nil if OBJECT seems to be a frame configuration.
+Any list whose car is `frame-configuration' is assumed to be a frame
+configuration."
+ (and (consp object)
+ (eq (car object) 'frame-configuration)))
+
+(defun functionp (object)
+ "Non-nil if OBJECT is any kind of function or a special form.
+Also non-nil if OBJECT is a symbol and its function definition is
+\(recursively) a function or special form. This does not include
+macros."
+ (or (and (symbolp object) (fboundp object)
+ (condition-case nil
+ (setq object (indirect-function object))
+ (error nil))
+ (eq (car-safe object) 'autoload)
+ (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
+ (subrp object) (byte-code-function-p object)
+ (eq (car-safe object) 'lambda)))
+\f
+;;;; List functions.
(defsubst caar (x)
"Return the car of the car of X."
next (+ from (* n inc)))))
(nreverse seq))))
-(defun remove (elt seq)
- "Return a copy of SEQ with all occurrences of ELT removed.
-SEQ must be a list, vector, or string. The comparison is done with `equal'."
- (if (nlistp seq)
- ;; If SEQ isn't a list, there's no need to copy SEQ because
- ;; `delete' will return a new object.
- (delete elt seq)
- (delete elt (copy-sequence seq))))
-
-(defun remq (elt list)
- "Return LIST with all occurrences of ELT removed.
-The comparison is done with `eq'. Contrary to `delq', this does not use
-side-effects, and the argument LIST is not modified."
- (if (memq elt list)
- (delq elt (copy-sequence list))
- list))
-
(defun copy-tree (tree &optional vecp)
"Make a copy of TREE.
If TREE is a cons cell, this recursively copies both its car and its cdr.
(aset tree i (copy-tree (aref tree i) vecp)))
tree)
tree)))
+\f
+;;;; Various list-search functions.
(defun assoc-default (key alist &optional test default)
"Find object KEY in a pseudo-alist ALIST.
(setq list (cdr list)))
list)
+(defun assq-delete-all (key alist)
+ "Delete from ALIST all elements whose car is `eq' to KEY.
+Return the modified alist.
+Elements of ALIST that are not conses are ignored."
+ (while (and (consp (car alist))
+ (eq (car (car alist)) key))
+ (setq alist (cdr alist)))
+ (let ((tail alist) tail-cdr)
+ (while (setq tail-cdr (cdr tail))
+ (if (and (consp (car tail-cdr))
+ (eq (car (car tail-cdr)) key))
+ (setcdr tail (cdr tail-cdr))
+ (setq tail tail-cdr))))
+ alist)
+
+(defun rassq-delete-all (value alist)
+ "Delete from ALIST all elements whose cdr is `eq' to VALUE.
+Return the modified alist.
+Elements of ALIST that are not conses are ignored."
+ (while (and (consp (car alist))
+ (eq (cdr (car alist)) value))
+ (setq alist (cdr alist)))
+ (let ((tail alist) tail-cdr)
+ (while (setq tail-cdr (cdr tail))
+ (if (and (consp (car tail-cdr))
+ (eq (cdr (car tail-cdr)) value))
+ (setcdr tail (cdr tail-cdr))
+ (setq tail tail-cdr))))
+ alist)
+
+(defun remove (elt seq)
+ "Return a copy of SEQ with all occurrences of ELT removed.
+SEQ must be a list, vector, or string. The comparison is done with `equal'."
+ (if (nlistp seq)
+ ;; If SEQ isn't a list, there's no need to copy SEQ because
+ ;; `delete' will return a new object.
+ (delete elt seq)
+ (delete elt (copy-sequence seq))))
+
+(defun remq (elt list)
+ "Return LIST with all occurrences of ELT removed.
+The comparison is done with `eq'. Contrary to `delq', this does not use
+side-effects, and the argument LIST is not modified."
+ (if (memq elt list)
+ (delq elt (copy-sequence list))
+ list))
\f
;;;; Keymap support.
+(defmacro kbd (keys)
+ "Convert KEYS to the internal Emacs key representation.
+KEYS should be a string constant in the format used for
+saving keyboard macros (see `edmacro-mode')."
+ (read-kbd-macro keys))
+
(defun undefined ()
(interactive)
(ding))
-;Prevent the \{...} documentation construct
-;from mentioning keys that run this command.
+;; Prevent the \{...} documentation construct
+;; from mentioning keys that run this command.
(put 'undefined 'suppress-keymap t)
(defun suppress-keymap (map &optional nodigits)
(define-key map (char-to-string loop) 'digit-argument)
(setq loop (1+ loop))))))
-;Moved to keymap.c
-;(defun copy-keymap (keymap)
-; "Return a copy of KEYMAP"
-; (while (not (keymapp keymap))
-; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
-; (if (vectorp keymap)
-; (copy-sequence keymap)
-; (copy-alist keymap)))
-
-(defvar key-substitution-in-progress nil
- "Used internally by substitute-key-definition.")
-
-(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
- "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
-In other words, OLDDEF is replaced with NEWDEF where ever it appears.
-Alternatively, if optional fourth argument OLDMAP is specified, we redefine
-in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP."
- ;; Don't document PREFIX in the doc string because we don't want to
- ;; advertise it. It's meant for recursive calls only. Here's its
- ;; meaning
-
- ;; If optional argument PREFIX is specified, it should be a key
- ;; prefix, a string. Redefined bindings will then be bound to the
- ;; original key, with PREFIX added at the front.
- (or prefix (setq prefix ""))
- (let* ((scan (or oldmap keymap))
- (vec1 (vector nil))
- (prefix1 (vconcat prefix vec1))
- (key-substitution-in-progress
- (cons scan key-substitution-in-progress)))
- ;; Scan OLDMAP, finding each char or event-symbol that
- ;; has any definition, and act on it with hack-key.
- (while (consp scan)
- (if (consp (car scan))
- (let ((char (car (car scan)))
- (defn (cdr (car scan))))
- ;; The inside of this let duplicates exactly
- ;; the inside of the following let that handles array elements.
- (aset vec1 0 char)
- (aset prefix1 (length prefix) char)
- (let (inner-def skipped)
- ;; Skip past menu-prompt.
- (while (stringp (car-safe defn))
- (setq skipped (cons (car defn) skipped))
- (setq defn (cdr defn)))
- ;; Skip past cached key-equivalence data for menu items.
- (and (consp defn) (consp (car defn))
- (setq defn (cdr defn)))
- (setq inner-def defn)
- ;; Look past a symbol that names a keymap.
- (while (and (symbolp inner-def)
- (fboundp inner-def))
- (setq inner-def (symbol-function inner-def)))
- (if (or (eq defn olddef)
- ;; Compare with equal if definition is a key sequence.
- ;; That is useful for operating on function-key-map.
- (and (or (stringp defn) (vectorp defn))
- (equal defn olddef)))
- (define-key keymap prefix1 (nconc (nreverse skipped) newdef))
- (if (and (keymapp defn)
- ;; Avoid recursively scanning
- ;; where KEYMAP does not have a submap.
- (let ((elt (lookup-key keymap prefix1)))
- (or (null elt)
- (keymapp elt)))
- ;; Avoid recursively rescanning keymap being scanned.
- (not (memq inner-def
- key-substitution-in-progress)))
- ;; If this one isn't being scanned already,
- ;; scan it now.
- (substitute-key-definition olddef newdef keymap
- inner-def
- prefix1)))))
- (if (vectorp (car scan))
- (let* ((array (car scan))
- (len (length array))
- (i 0))
- (while (< i len)
- (let ((char i) (defn (aref array i)))
- ;; The inside of this let duplicates exactly
- ;; the inside of the previous let.
- (aset vec1 0 char)
- (aset prefix1 (length prefix) char)
- (let (inner-def skipped)
- ;; Skip past menu-prompt.
- (while (stringp (car-safe defn))
- (setq skipped (cons (car defn) skipped))
- (setq defn (cdr defn)))
- (and (consp defn) (consp (car defn))
- (setq defn (cdr defn)))
- (setq inner-def defn)
- (while (and (symbolp inner-def)
- (fboundp inner-def))
- (setq inner-def (symbol-function inner-def)))
- (if (or (eq defn olddef)
- (and (or (stringp defn) (vectorp defn))
- (equal defn olddef)))
- (define-key keymap prefix1
- (nconc (nreverse skipped) newdef))
- (if (and (keymapp defn)
- (let ((elt (lookup-key keymap prefix1)))
- (or (null elt)
- (keymapp elt)))
- (not (memq inner-def
- key-substitution-in-progress)))
- (substitute-key-definition olddef newdef keymap
- inner-def
- prefix1)))))
- (setq i (1+ i))))
- (if (char-table-p (car scan))
- (map-char-table
- (function (lambda (char defn)
- (let ()
- ;; The inside of this let duplicates exactly
- ;; the inside of the previous let,
- ;; except that it uses set-char-table-range
- ;; instead of define-key.
- (aset vec1 0 char)
- (aset prefix1 (length prefix) char)
- (let (inner-def skipped)
- ;; Skip past menu-prompt.
- (while (stringp (car-safe defn))
- (setq skipped (cons (car defn) skipped))
- (setq defn (cdr defn)))
- (and (consp defn) (consp (car defn))
- (setq defn (cdr defn)))
- (setq inner-def defn)
- (while (and (symbolp inner-def)
- (fboundp inner-def))
- (setq inner-def (symbol-function inner-def)))
- (if (or (eq defn olddef)
- (and (or (stringp defn) (vectorp defn))
- (equal defn olddef)))
- (define-key keymap prefix1
- (nconc (nreverse skipped) newdef))
- (if (and (keymapp defn)
- (let ((elt (lookup-key keymap prefix1)))
- (or (null elt)
- (keymapp elt)))
- (not (memq inner-def
- key-substitution-in-progress)))
- (substitute-key-definition olddef newdef keymap
- inner-def
- prefix1)))))))
- (car scan)))))
- (setq scan (cdr scan)))))
-
(defun define-key-after (keymap key definition &optional after)
"Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
This is like `define-key' except that the binding for KEY is placed
(setq inserted t)))
(setq tail (cdr tail)))))
-
-(defmacro kbd (keys)
- "Convert KEYS to the internal Emacs key representation.
-KEYS should be a string constant in the format used for
-saving keyboard macros (see `edmacro-mode')."
- (read-kbd-macro keys))
+(defun map-keymap-internal (function keymap &optional sort-first)
+ "Implement `map-keymap' with sorting.
+Don't call this function; it is for internal use only."
+ (if sort-first
+ (let (list)
+ (map-keymap (lambda (a b) (push (cons a b) list))
+ keymap)
+ (setq list (sort list
+ (lambda (a b)
+ (setq a (car a) b (car b))
+ (if (integerp a)
+ (if (integerp b) (< a b)
+ t)
+ (if (integerp b) t
+ (string< a b))))))
+ (dolist (p list)
+ (funcall function (car p) (cdr p))))
+ (map-keymap function keymap)))
(put 'keyboard-translate-table 'char-table-extra-slots 0)
(setq keyboard-translate-table
(make-char-table 'keyboard-translate-table nil)))
(aset keyboard-translate-table from to))
+\f
+;;;; Key binding commands.
+
+(defun global-set-key (key command)
+ "Give KEY a global binding as COMMAND.
+COMMAND is the command definition to use; usually it is
+a symbol naming an interactively-callable function.
+KEY is a key sequence; noninteractively, it is a string or vector
+of characters or event types, and non-ASCII characters with codes
+above 127 (such as ISO Latin-1) can be included if you use a vector.
+
+Note that if KEY has a local binding in the current buffer,
+that local binding will continue to shadow any global binding
+that you make with this function."
+ (interactive "KSet key globally: \nCSet key %s to command: ")
+ (or (vectorp key) (stringp key)
+ (signal 'wrong-type-argument (list 'arrayp key)))
+ (define-key (current-global-map) key command))
+
+(defun local-set-key (key command)
+ "Give KEY a local binding as COMMAND.
+COMMAND is the command definition to use; usually it is
+a symbol naming an interactively-callable function.
+KEY is a key sequence; noninteractively, it is a string or vector
+of characters or event types, and non-ASCII characters with codes
+above 127 (such as ISO Latin-1) can be included if you use a vector.
+
+The binding goes in the current buffer's local map,
+which in most cases is shared with all other buffers in the same major mode."
+ (interactive "KSet key locally: \nCSet key %s locally to command: ")
+ (let ((map (current-local-map)))
+ (or map
+ (use-local-map (setq map (make-sparse-keymap))))
+ (or (vectorp key) (stringp key)
+ (signal 'wrong-type-argument (list 'arrayp key)))
+ (define-key map key command)))
+
+(defun global-unset-key (key)
+ "Remove global binding of KEY.
+KEY is a string or vector representing a sequence of keystrokes."
+ (interactive "kUnset key globally: ")
+ (global-set-key key nil))
+
+(defun local-unset-key (key)
+ "Remove local binding of KEY.
+KEY is a string or vector representing a sequence of keystrokes."
+ (interactive "kUnset key locally: ")
+ (if (current-local-map)
+ (local-set-key key nil))
+ nil)
+\f
+;;;; substitute-key-definition and its subroutines.
+
+(defvar key-substitution-in-progress nil
+ "Used internally by `substitute-key-definition'.")
+
+(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
+ "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
+In other words, OLDDEF is replaced with NEWDEF where ever it appears.
+Alternatively, if optional fourth argument OLDMAP is specified, we redefine
+in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP.
+
+If you don't specify OLDMAP, you can usually get the same results
+in a cleaner way with command remapping, like this:
+ \(define-key KEYMAP [remap OLDDEF] NEWDEF)
+\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)"
+ ;; Don't document PREFIX in the doc string because we don't want to
+ ;; advertise it. It's meant for recursive calls only. Here's its
+ ;; meaning
+
+ ;; If optional argument PREFIX is specified, it should be a key
+ ;; prefix, a string. Redefined bindings will then be bound to the
+ ;; original key, with PREFIX added at the front.
+ (or prefix (setq prefix ""))
+ (let* ((scan (or oldmap keymap))
+ (prefix1 (vconcat prefix [nil]))
+ (key-substitution-in-progress
+ (cons scan key-substitution-in-progress)))
+ ;; Scan OLDMAP, finding each char or event-symbol that
+ ;; has any definition, and act on it with hack-key.
+ (map-keymap
+ (lambda (char defn)
+ (aset prefix1 (length prefix) char)
+ (substitute-key-definition-key defn olddef newdef prefix1 keymap))
+ scan)))
+
+(defun substitute-key-definition-key (defn olddef newdef prefix keymap)
+ (let (inner-def skipped menu-item)
+ ;; Find the actual command name within the binding.
+ (if (eq (car-safe defn) 'menu-item)
+ (setq menu-item defn defn (nth 2 defn))
+ ;; Skip past menu-prompt.
+ (while (stringp (car-safe defn))
+ (push (pop defn) skipped))
+ ;; Skip past cached key-equivalence data for menu items.
+ (if (consp (car-safe defn))
+ (setq defn (cdr defn))))
+ (if (or (eq defn olddef)
+ ;; Compare with equal if definition is a key sequence.
+ ;; That is useful for operating on function-key-map.
+ (and (or (stringp defn) (vectorp defn))
+ (equal defn olddef)))
+ (define-key keymap prefix
+ (if menu-item
+ (let ((copy (copy-sequence menu-item)))
+ (setcar (nthcdr 2 copy) newdef)
+ copy)
+ (nconc (nreverse skipped) newdef)))
+ ;; Look past a symbol that names a keymap.
+ (setq inner-def
+ (or (indirect-function defn t) defn))
+ ;; For nested keymaps, we use `inner-def' rather than `defn' so as to
+ ;; avoid autoloading a keymap. This is mostly done to preserve the
+ ;; original non-autoloading behavior of pre-map-keymap times.
+ (if (and (keymapp inner-def)
+ ;; Avoid recursively scanning
+ ;; where KEYMAP does not have a submap.
+ (let ((elt (lookup-key keymap prefix)))
+ (or (null elt) (natnump elt) (keymapp elt)))
+ ;; Avoid recursively rescanning keymap being scanned.
+ (not (memq inner-def key-substitution-in-progress)))
+ ;; If this one isn't being scanned already, scan it now.
+ (substitute-key-definition olddef newdef keymap inner-def prefix)))))
\f
;;;; The global keymap tree.
(char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
?\H-\^@ ?\s-\^@ ?\A-\^@)))))
(if (not (zerop (logand type ?\M-\^@)))
- (setq list (cons 'meta list)))
+ (push 'meta list))
(if (or (not (zerop (logand type ?\C-\^@)))
(< char 32))
- (setq list (cons 'control list)))
+ (push 'control list))
(if (or (not (zerop (logand type ?\S-\^@)))
(/= char (downcase char)))
- (setq list (cons 'shift list)))
+ (push 'shift list))
(or (zerop (logand type ?\H-\^@))
- (setq list (cons 'hyper list)))
+ (push 'hyper list))
(or (zerop (logand type ?\s-\^@))
- (setq list (cons 'super list)))
+ (push 'super list))
(or (zerop (logand type ?\A-\^@))
- (setq list (cons 'alt list)))
+ (push 'alt list))
list))))
(defun event-basic-type (event)
(setq event (car event)))
(if (symbolp event)
(car (get event 'event-symbol-elements))
- (let ((base (logand event (1- ?\A-\^@))))
- (downcase (if (< base 32) (logior base 64) base)))))
+ (let* ((base (logand event (1- ?\A-\^@)))
+ (uncontrolled (if (< base 32) (logior base 64) base)))
+ ;; There are some numbers that are invalid characters and
+ ;; cause `downcase' to get an error.
+ (condition-case ()
+ (downcase uncontrolled)
+ (error uncontrolled)))))
(defsubst mouse-movement-p (object)
"Return non-nil if OBJECT is a mouse movement event."
- (and (consp object)
- (eq (car object) 'mouse-movement)))
+ (eq (car-safe object) 'mouse-movement))
(defsubst event-start (event)
"Return the starting position of EVENT.
"Return the multi-click count of EVENT, a click or drag event.
The return value is a positive integer."
(if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
+\f
+;;;; Extracting fields of the positions in an event.
(defsubst posn-window (position)
"Return the window in POSITION.
(nth 3 position))
(defsubst posn-string (position)
- "Return the string object of POSITION, or nil if a buffer position.
+ "Return the string object of POSITION.
+Value is a cons (STRING . STRING-POS), or nil if not a string.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
(nth 4 position))
(defsubst posn-image (position)
- "Return the image object of POSITION, or nil if a not an image.
+ "Return the image object of POSITION.
+Value is an list (image ...), or nil if not an image.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
(nth 7 position))
(defsubst posn-object (position)
"Return the object (image or string) of POSITION.
+Value is a list (image ...) for an image object, a cons cell
+\(STRING . STRING-POS) for a string object, and nil for a buffer position.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
(or (posn-image position) (posn-string position)))
\f
;;;; Obsolescent names for functions.
-(defalias 'dot 'point)
-(defalias 'dot-marker 'point-marker)
-(defalias 'dot-min 'point-min)
-(defalias 'dot-max 'point-max)
-(defalias 'window-dot 'window-point)
-(defalias 'set-window-dot 'set-window-point)
-(defalias 'read-input 'read-string)
-(defalias 'send-string 'process-send-string)
-(defalias 'send-region 'process-send-region)
-(defalias 'show-buffer 'set-window-buffer)
-(defalias 'buffer-flush-undo 'buffer-disable-undo)
-(defalias 'eval-current-buffer 'eval-buffer)
-(defalias 'compiled-function-p 'byte-code-function-p)
-(defalias 'define-function 'defalias)
-
-(defalias 'sref 'aref)
-(make-obsolete 'sref 'aref "20.4")
+(define-obsolete-function-alias 'window-dot 'window-point "22.1")
+(define-obsolete-function-alias 'set-window-dot 'set-window-point "22.1")
+(define-obsolete-function-alias 'read-input 'read-string "22.1")
+(define-obsolete-function-alias 'show-buffer 'set-window-buffer "22.1")
+(define-obsolete-function-alias 'eval-current-buffer 'eval-buffer "22.1")
+(define-obsolete-function-alias 'string-to-int 'string-to-number "22.1")
+
(make-obsolete 'char-bytes "now always returns 1." "20.4")
-(make-obsolete 'chars-in-region "use (abs (- BEG END))." "20.3")
-(make-obsolete 'dot 'point "before 19.15")
-(make-obsolete 'dot-max 'point-max "before 19.15")
-(make-obsolete 'dot-min 'point-min "before 19.15")
-(make-obsolete 'dot-marker 'point-marker "before 19.15")
-(make-obsolete 'buffer-flush-undo 'buffer-disable-undo "before 19.15")
-(make-obsolete 'baud-rate "use the `baud-rate' variable instead." "before 19.15")
-(make-obsolete 'compiled-function-p 'byte-code-function-p "before 19.15")
-(make-obsolete 'define-function 'defalias "20.1")
-(make-obsolete 'focus-frame "it does nothing." "19.32")
-(make-obsolete 'unfocus-frame "it does nothing." "19.32")
(defun insert-string (&rest args)
"Mocklisp-compatibility insert function.
is converted into a string by expressing it in decimal."
(dolist (el args)
(insert (if (integerp el) (number-to-string el) el))))
-(make-obsolete 'insert-string 'insert "21.4")
+(make-obsolete 'insert-string 'insert "22.1")
+
(defun makehash (&optional test) (make-hash-table :test (or test 'eql)))
-(make-obsolete 'makehash 'make-hash-table "21.4")
+(make-obsolete 'makehash 'make-hash-table "22.1")
;; Some programs still use this as a function.
(defun baud-rate ()
"Return the value of the `baud-rate' variable."
baud-rate)
+(make-obsolete 'baud-rate "use the `baud-rate' variable instead." "before 19.15")
+;; These are used by VM and some old programs
(defalias 'focus-frame 'ignore "")
+(make-obsolete 'focus-frame "it does nothing." "22.1")
(defalias 'unfocus-frame 'ignore "")
+(make-obsolete 'unfocus-frame "it does nothing." "22.1")
\f
-;;;; Obsolescence declarations for variables.
+;;;; Obsolescence declarations for variables, and aliases.
(make-obsolete-variable 'directory-sep-char "do not use it." "21.1")
(make-obsolete-variable 'mode-line-inverse-video "use the appropriate faces instead." "21.1")
(make-obsolete-variable 'unread-command-char
"use `unread-command-events' instead. That variable is a list of events to reread, so it now uses nil to mean `no event', instead of -1."
"before 19.15")
-(make-obsolete-variable 'executing-macro 'executing-kbd-macro "before 19.34")
-(make-obsolete-variable 'post-command-idle-hook
- "use timers instead, with `run-with-idle-timer'." "before 19.34")
-(make-obsolete-variable 'post-command-idle-delay
- "use timers instead, with `run-with-idle-timer'." "before 19.34")
+;; Lisp manual only updated in 22.1.
+(define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro
+ "before 19.34")
+
+(defvaralias 'x-lost-selection-hooks 'x-lost-selection-functions)
+(make-obsolete-variable 'x-lost-selection-hooks 'x-lost-selection-functions "22.1")
+(defvaralias 'x-sent-selection-hooks 'x-sent-selection-functions)
+(make-obsolete-variable 'x-sent-selection-hooks 'x-sent-selection-functions "22.1")
+
+(defvaralias 'messages-buffer-max-lines 'message-log-max)
\f
;;;; Alternate names for functions - these are not being phased out.
+(defalias 'send-string 'process-send-string)
+(defalias 'send-region 'process-send-region)
(defalias 'string= 'string-equal)
(defalias 'string< 'string-lessp)
(defalias 'move-marker 'set-marker)
(defalias 'point-at-eol 'line-end-position)
(defalias 'point-at-bol 'line-beginning-position)
-;;; Should this be an obsolete name? If you decide it should, you get
-;;; to go through all the sources and change them.
-(defalias 'string-to-int 'string-to-number)
+(defalias 'user-original-login-name 'user-login-name)
+
\f
;;;; Hook manipulation functions.
(set hook hook-value))))))
(defun add-to-list (list-var element &optional append)
- "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
+ "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
The test for presence of ELEMENT is done with `equal'.
If ELEMENT is added, it is added at the beginning of the list,
unless the optional argument APPEND is non-nil, in which case
(append (symbol-value list-var) (list element))
(cons element (symbol-value list-var))))))
-\f
-;;; Load history
-;;; (defvar symbol-file-load-history-loaded nil
-;;; "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
-;;; That file records the part of `load-history' for preloaded files,
-;;; which is cleared out before dumping to make Emacs smaller.")
-
-;;; (defun load-symbol-file-load-history ()
-;;; "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
-;;; That file records the part of `load-history' for preloaded files,
-;;; which is cleared out before dumping to make Emacs smaller."
-;;; (unless symbol-file-load-history-loaded
-;;; (load (expand-file-name
-;;; ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
-;;; (if (eq system-type 'ms-dos)
-;;; "fns.el"
-;;; (format "fns-%s.el" emacs-version))
-;;; exec-directory)
-;;; ;; The file name fns-%s.el already has a .el extension.
-;;; nil nil t)
-;;; (setq symbol-file-load-history-loaded t)))
-
-(defun symbol-file (function)
- "Return the input source from which FUNCTION was loaded.
-The value is normally a string that was passed to `load':
-either an absolute file name, or a library name
-\(with no directory name and no `.el' or `.elc' at the end).
-It can also be nil, if the definition is not associated with any file."
- (if (and (symbolp function) (fboundp function)
- (eq 'autoload (car-safe (symbol-function function))))
- (nth 1 (symbol-function function))
- (let ((files load-history)
- file)
- (while files
- (if (member function (cdr (car files)))
- (setq file (car (car files)) files nil))
- (setq files (cdr files)))
- file)))
+(defun add-to-ordered-list (list-var element &optional order)
+ "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
+The test for presence of ELEMENT is done with `eq'.
+
+The resulting list is reordered so that the elements are in the
+order given by each element's numeric list order. Elements
+without a numeric list order are placed at the end of the list.
+
+If the third optional argument ORDER is a number (integer or
+float), set the element's list order to the given value. If
+ORDER is nil or omitted, do not change the numeric order of
+ELEMENT. If ORDER has any other value, remove the numeric order
+of ELEMENT if it has one.
+
+The list order for each element is stored in LIST-VAR's
+`list-order' property.
+
+The return value is the new value of LIST-VAR."
+ (let ((ordering (get list-var 'list-order)))
+ (unless ordering
+ (put list-var 'list-order
+ (setq ordering (make-hash-table :weakness 'key :test 'eq))))
+ (when order
+ (puthash element (and (numberp order) order) ordering))
+ (unless (memq element (symbol-value list-var))
+ (set list-var (cons element (symbol-value list-var))))
+ (set list-var (sort (symbol-value list-var)
+ (lambda (a b)
+ (let ((oa (gethash a ordering))
+ (ob (gethash b ordering)))
+ (if (and oa ob)
+ (< oa ob)
+ oa)))))))
+
+(defun add-to-history (history-var newelt &optional maxelt keep-dups)
+ "Add NEWELT to the history list stored in the variable HISTORY-VAR.
+Return the new history list.
+If MAXELT is non-nil, it specifies the maximum length of the history.
+Otherwise, the maximum history length is the value of the `history-length'
+property on symbol HISTORY-VAR, if set, or the value of the `history-length'
+variable.
+Remove duplicates of NEWELT unless `history-delete-duplicates' is nil
+or KEEP-DUPS is non-nil."
+ (unless maxelt
+ (setq maxelt (or (get history-var 'history-length)
+ history-length)))
+ (let ((history (symbol-value history-var))
+ tail)
+ (if (and history-delete-duplicates (not keep-dups))
+ (setq history (delete newelt history)))
+ (setq history (cons newelt history))
+ (when (integerp maxelt)
+ (if (= 0 maxelt)
+ (setq history nil)
+ (setq tail (nthcdr (1- maxelt) history))
+ (when (consp tail)
+ (setcdr tail nil))))
+ (set history-var history)))
\f
-;;;; Specifying things to do after certain files are loaded.
+;;;; Mode hooks.
-(defun eval-after-load (file form)
- "Arrange that, if FILE is ever loaded, FORM will be run at that time.
-This makes or adds to an entry on `after-load-alist'.
-If FILE is already loaded, evaluate FORM right now.
-It does nothing if FORM is already on the list for FILE.
-FILE must match exactly. Normally FILE is the name of a library,
-with no directory or extension specified, since that is how `load'
-is normally called.
-FILE can also be a feature (i.e. a symbol), in which case FORM is
-evaluated whenever that feature is `provide'd."
- (let ((elt (assoc file after-load-alist)))
- ;; Make sure there is an element for FILE.
- (unless elt (setq elt (list file)) (push elt after-load-alist))
- ;; Add FORM to the element if it isn't there.
- (unless (member form (cdr elt))
- (nconc elt (list form))
- ;; If the file has been loaded already, run FORM right away.
- (if (if (symbolp file)
- (featurep file)
- ;; Make sure `load-history' contains the files dumped with
- ;; Emacs for the case that FILE is one of them.
- ;; (load-symbol-file-load-history)
- (assoc file load-history))
- (eval form))))
- form)
+(defvar delay-mode-hooks nil
+ "If non-nil, `run-mode-hooks' should delay running the hooks.")
+(defvar delayed-mode-hooks nil
+ "List of delayed mode hooks waiting to be run.")
+(make-variable-buffer-local 'delayed-mode-hooks)
+(put 'delay-mode-hooks 'permanent-local t)
-(defun eval-next-after-load (file)
- "Read the following input sexp, and run it whenever FILE is loaded.
-This makes or adds to an entry on `after-load-alist'.
-FILE should be the name of a library, with no directory name."
- (eval-after-load file (read)))
-\f
-;;; make-network-process wrappers
+(defvar after-change-major-mode-hook nil
+ "Normal hook run at the very end of major mode functions.")
-(if (featurep 'make-network-process)
- (progn
+(defun run-mode-hooks (&rest hooks)
+ "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
+Execution is delayed if `delay-mode-hooks' is non-nil.
+If `delay-mode-hooks' is nil, run `after-change-major-mode-hook'
+after running the mode hooks.
+Major mode functions should use this."
+ (if delay-mode-hooks
+ ;; Delaying case.
+ (dolist (hook hooks)
+ (push hook delayed-mode-hooks))
+ ;; Normal case, just run the hook as before plus any delayed hooks.
+ (setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
+ (setq delayed-mode-hooks nil)
+ (apply 'run-hooks hooks)
+ (run-hooks 'after-change-major-mode-hook)))
-(defun open-network-stream (name buffer host service)
- "Open a TCP connection for a service to a host.
+(defmacro delay-mode-hooks (&rest body)
+ "Execute BODY, but delay any `run-mode-hooks'.
+These hooks will be executed by the first following call to
+`run-mode-hooks' that occurs outside any `delayed-mode-hooks' form.
+Only affects hooks run in the current buffer."
+ (declare (debug t) (indent 0))
+ `(progn
+ (make-local-variable 'delay-mode-hooks)
+ (let ((delay-mode-hooks t))
+ ,@body)))
+
+;; PUBLIC: find if the current mode derives from another.
+
+(defun derived-mode-p (&rest modes)
+ "Non-nil if the current major mode is derived from one of MODES.
+Uses the `derived-mode-parent' property of the symbol to trace backwards."
+ (let ((parent major-mode))
+ (while (and (not (memq parent modes))
+ (setq parent (get parent 'derived-mode-parent))))
+ parent))
+\f
+;;;; Minor modes.
+
+;; If a minor mode is not defined with define-minor-mode,
+;; add it here explicitly.
+;; isearch-mode is deliberately excluded, since you should
+;; not call it yourself.
+(defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode
+ overwrite-mode view-mode
+ hs-minor-mode)
+ "List of all minor mode functions.")
+
+(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
+ "Register a new minor mode.
+
+This is an XEmacs-compatibility function. Use `define-minor-mode' instead.
+
+TOGGLE is a symbol which is the name of a buffer-local variable that
+is toggled on or off to say whether the minor mode is active or not.
+
+NAME specifies what will appear in the mode line when the minor mode
+is active. NAME should be either a string starting with a space, or a
+symbol whose value is such a string.
+
+Optional KEYMAP is the keymap for the minor mode that will be added
+to `minor-mode-map-alist'.
+
+Optional AFTER specifies that TOGGLE should be added after AFTER
+in `minor-mode-alist'.
+
+Optional TOGGLE-FUN is an interactive function to toggle the mode.
+It defaults to (and should by convention be) TOGGLE.
+
+If TOGGLE has a non-nil `:included' property, an entry for the mode is
+included in the mode-line minor mode menu.
+If TOGGLE has a `:menu-tag', that is used for the menu item's label."
+ (unless (memq toggle minor-mode-list)
+ (push toggle minor-mode-list))
+
+ (unless toggle-fun (setq toggle-fun toggle))
+ (unless (eq toggle-fun toggle)
+ (put toggle :minor-mode-function toggle-fun))
+ ;; Add the name to the minor-mode-alist.
+ (when name
+ (let ((existing (assq toggle minor-mode-alist)))
+ (if existing
+ (setcdr existing (list name))
+ (let ((tail minor-mode-alist) found)
+ (while (and tail (not found))
+ (if (eq after (caar tail))
+ (setq found tail)
+ (setq tail (cdr tail))))
+ (if found
+ (let ((rest (cdr found)))
+ (setcdr found nil)
+ (nconc found (list (list toggle name)) rest))
+ (setq minor-mode-alist (cons (list toggle name)
+ minor-mode-alist)))))))
+ ;; Add the toggle to the minor-modes menu if requested.
+ (when (get toggle :included)
+ (define-key mode-line-mode-menu
+ (vector toggle)
+ (list 'menu-item
+ (concat
+ (or (get toggle :menu-tag)
+ (if (stringp name) name (symbol-name toggle)))
+ (let ((mode-name (if (symbolp name) (symbol-value name))))
+ (if (and (stringp mode-name) (string-match "[^ ]+" mode-name))
+ (concat " (" (match-string 0 mode-name) ")"))))
+ toggle-fun
+ :button (cons :toggle toggle))))
+
+ ;; Add the map to the minor-mode-map-alist.
+ (when keymap
+ (let ((existing (assq toggle minor-mode-map-alist)))
+ (if existing
+ (setcdr existing keymap)
+ (let ((tail minor-mode-map-alist) found)
+ (while (and tail (not found))
+ (if (eq after (caar tail))
+ (setq found tail)
+ (setq tail (cdr tail))))
+ (if found
+ (let ((rest (cdr found)))
+ (setcdr found nil)
+ (nconc found (list (cons toggle keymap)) rest))
+ (setq minor-mode-map-alist (cons (cons toggle keymap)
+ minor-mode-map-alist))))))))
+\f
+;;; Load history
+
+;; (defvar symbol-file-load-history-loaded nil
+;; "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
+;; That file records the part of `load-history' for preloaded files,
+;; which is cleared out before dumping to make Emacs smaller.")
+
+;; (defun load-symbol-file-load-history ()
+;; "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
+;; That file records the part of `load-history' for preloaded files,
+;; which is cleared out before dumping to make Emacs smaller."
+;; (unless symbol-file-load-history-loaded
+;; (load (expand-file-name
+;; ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
+;; (if (eq system-type 'ms-dos)
+;; "fns.el"
+;; (format "fns-%s.el" emacs-version))
+;; exec-directory)
+;; ;; The file name fns-%s.el already has a .el extension.
+;; nil nil t)
+;; (setq symbol-file-load-history-loaded t)))
+
+(defun symbol-file (symbol &optional type)
+ "Return the input source in which SYMBOL was defined.
+The value is an absolute file name.
+It can also be nil, if the definition is not associated with any file.
+
+If TYPE is nil, then any kind of definition is acceptable.
+If TYPE is `defun' or `defvar', that specifies function
+definition only or variable definition only.
+`defface' specifies a face definition only."
+ (if (and (or (null type) (eq type 'defun))
+ (symbolp symbol) (fboundp symbol)
+ (eq 'autoload (car-safe (symbol-function symbol))))
+ (nth 1 (symbol-function symbol))
+ (let ((files load-history)
+ file)
+ (while files
+ (if (if type
+ (if (eq type 'defvar)
+ ;; Variables are present just as their names.
+ (member symbol (cdr (car files)))
+ ;; Other types are represented as (TYPE . NAME).
+ (member (cons type symbol) (cdr (car files))))
+ ;; We accept all types, so look for variable def
+ ;; and then for any other kind.
+ (or (member symbol (cdr (car files)))
+ (rassq symbol (cdr (car files)))))
+ (setq file (car (car files)) files nil))
+ (setq files (cdr files)))
+ file)))
+
+;;;###autoload
+(defun locate-library (library &optional nosuffix path interactive-call)
+ "Show the precise file name of Emacs library LIBRARY.
+This command searches the directories in `load-path' like `\\[load-library]'
+to find the file that `\\[load-library] RET LIBRARY RET' would load.
+Optional second arg NOSUFFIX non-nil means don't add suffixes `load-suffixes'
+to the specified name LIBRARY.
+
+If the optional third arg PATH is specified, that list of directories
+is used instead of `load-path'.
+
+When called from a program, the file name is normaly returned as a
+string. When run interactively, the argument INTERACTIVE-CALL is t,
+and the file name is displayed in the echo area."
+ (interactive (list (completing-read "Locate library: "
+ 'locate-file-completion
+ (cons load-path (get-load-suffixes)))
+ nil nil
+ t))
+ (let ((file (locate-file library
+ (or path load-path)
+ (append (unless nosuffix (get-load-suffixes))
+ load-file-rep-suffixes))))
+ (if interactive-call
+ (if file
+ (message "Library is file %s" (abbreviate-file-name file))
+ (message "No library %s in search path" library)))
+ file))
+
+\f
+;;;; Specifying things to do later.
+
+(defmacro eval-at-startup (&rest body)
+ "Make arrangements to evaluate BODY when Emacs starts up.
+If this is run after Emacs startup, evaluate BODY immediately.
+Always returns nil.
+
+This works by adding a function to `before-init-hook'.
+That function's doc string says which file created it."
+ `(progn
+ (if command-line-processed
+ (progn . ,body)
+ (add-hook 'before-init-hook
+ '(lambda () ,(concat "From " (or load-file-name "no file"))
+ . ,body)
+ t))
+ nil))
+
+(defun eval-after-load (file form)
+ "Arrange that, if FILE is ever loaded, FORM will be run at that time.
+This makes or adds to an entry on `after-load-alist'.
+If FILE is already loaded, evaluate FORM right now.
+It does nothing if FORM is already on the list for FILE.
+FILE must match exactly. Normally FILE is the name of a library,
+with no directory or extension specified, since that is how `load'
+is normally called.
+FILE can also be a feature (i.e. a symbol), in which case FORM is
+evaluated whenever that feature is `provide'd."
+ (let ((elt (assoc file after-load-alist)))
+ ;; Make sure there is an element for FILE.
+ (unless elt (setq elt (list file)) (push elt after-load-alist))
+ ;; Add FORM to the element if it isn't there.
+ (unless (member form (cdr elt))
+ (nconc elt (list form))
+ ;; If the file has been loaded already, run FORM right away.
+ (if (if (symbolp file)
+ (featurep file)
+ ;; Make sure `load-history' contains the files dumped with
+ ;; Emacs for the case that FILE is one of them.
+ ;; (load-symbol-file-load-history)
+ (when (locate-library file)
+ (assoc (locate-library file) load-history)))
+ (eval form))))
+ form)
+
+(defun eval-next-after-load (file)
+ "Read the following input sexp, and run it whenever FILE is loaded.
+This makes or adds to an entry on `after-load-alist'.
+FILE should be the name of a library, with no directory name."
+ (eval-after-load file (read)))
+\f
+;;;; Process stuff.
+
+;; open-network-stream is a wrapper around make-network-process.
+
+(when (featurep 'make-network-process)
+ (defun open-network-stream (name buffer host service)
+ "Open a TCP connection for a service to a host.
Returns a subprocess-object to represent the connection.
Input and output work as for subprocesses; `delete-process' closes it.
SERVICE is name of the service desired, or an integer specifying
a port number to connect to."
(make-network-process :name name :buffer buffer
- :host host :service service))
-
-(defun open-network-stream-nowait (name buffer host service &optional sentinel filter)
- "Initiate connection to a TCP connection for a service to a host.
-It returns nil if non-blocking connects are not supported; otherwise,
-it returns a subprocess-object to represent the connection.
-
-This function is similar to `open-network-stream', except that it
-returns before the connection is established. When the connection
-is completed, the sentinel function will be called with second arg
-matching `open' (if successful) or `failed' (on error).
-
-Args are NAME BUFFER HOST SERVICE SENTINEL FILTER.
-NAME, BUFFER, HOST, and SERVICE are as for `open-network-stream'.
-Optional args SENTINEL and FILTER specify the sentinel and filter
-functions to be used for this network stream."
- (if (featurep 'make-network-process '(:nowait t))
- (make-network-process :name name :buffer buffer :nowait t
- :host host :service service
- :filter filter :sentinel sentinel)))
-
-(defun open-network-stream-server (name buffer service &optional sentinel filter)
- "Create a network server process for a TCP service.
-It returns nil if server processes are not supported; otherwise,
-it returns a subprocess-object to represent the server.
-
-When a client connects to the specified service, a new subprocess
-is created to handle the new connection, and the sentinel function
-is called for the new process.
-
-Args are NAME BUFFER SERVICE SENTINEL FILTER.
-NAME is name for the server process. Client processes are named by
- appending the ip-address and port number of the client to NAME.
-BUFFER is the buffer (or buffer name) to associate with the server
- process. Client processes will not get a buffer if a process filter
- is specified or BUFFER is nil; otherwise, a new buffer is created for
- the client process. The name is similar to the process name.
-Third arg SERVICE is name of the service desired, or an integer
- specifying a port number to connect to. It may also be t to select
- an unused port number for the server.
-Optional args SENTINEL and FILTER specify the sentinel and filter
- functions to be used for the client processes; the server process
- does not use these function."
- (if (featurep 'make-network-process '(:server t))
- (make-network-process :name name :buffer buffer
- :service service :server t :noquery t
- :sentinel sentinel :filter filter)))
-
-)) ;; (featurep 'make-network-process)
-
+ :host host :service service)))
;; compatibility
(make-obsolete 'process-kill-without-query
"use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
- "21.4")
+ "22.1")
(defun process-kill-without-query (process &optional flag)
"Say no query needed if PROCESS is running when Emacs is exited.
Optional second argument if non-nil says to require a query.
code))
(defun read-passwd (prompt &optional confirm default)
- "Read a password, prompting with PROMPT. Echo `.' for each character typed.
-End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line.
-If optional CONFIRM is non-nil, read password twice to make sure.
-Optional DEFAULT is a default password to use instead of empty input."
- (if confirm
- (let (success)
- (while (not success)
- (let ((first (read-passwd prompt nil default))
- (second (read-passwd "Confirm password: " nil default)))
- (if (equal first second)
- (progn
- (and (arrayp second) (clear-string second))
- (setq success first))
- (and (arrayp first) (clear-string first))
- (and (arrayp second) (clear-string second))
- (message "Password not repeated accurately; please start over")
- (sit-for 1))))
- success)
- (let ((pass nil)
- (c 0)
- (echo-keystrokes 0)
- (cursor-in-echo-area t))
- (while (progn (message "%s%s"
- prompt
- (make-string (length pass) ?.))
- (setq c (read-char-exclusive nil t))
- (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
- (clear-this-command-keys)
- (if (= c ?\C-u)
- (progn
- (and (arrayp pass) (clear-string pass))
- (setq pass ""))
- (if (and (/= c ?\b) (/= c ?\177))
- (let* ((new-char (char-to-string c))
- (new-pass (concat pass new-char)))
+ "Read a password, prompting with PROMPT, and return it.
+If optional CONFIRM is non-nil, read the password twice to make sure.
+Optional DEFAULT is a default password to use instead of empty input.
+
+This function echoes `.' for each character that the user types.
+The user ends with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line.
+C-g quits; if `inhibit-quit' was non-nil around this function,
+then it returns nil if the user types C-g.
+
+Once the caller uses the password, it can erase the password
+by doing (clear-string STRING)."
+ (with-local-quit
+ (if confirm
+ (let (success)
+ (while (not success)
+ (let ((first (read-passwd prompt nil default))
+ (second (read-passwd "Confirm password: " nil default)))
+ (if (equal first second)
+ (progn
+ (and (arrayp second) (clear-string second))
+ (setq success first))
+ (and (arrayp first) (clear-string first))
+ (and (arrayp second) (clear-string second))
+ (message "Password not repeated accurately; please start over")
+ (sit-for 1))))
+ success)
+ (let ((pass nil)
+ (c 0)
+ (echo-keystrokes 0)
+ (cursor-in-echo-area t)
+ (message-log-max nil))
+ (add-text-properties 0 (length prompt)
+ minibuffer-prompt-properties prompt)
+ (while (progn (message "%s%s"
+ prompt
+ (make-string (length pass) ?.))
+ (setq c (read-char-exclusive nil t))
+ (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
+ (clear-this-command-keys)
+ (if (= c ?\C-u)
+ (progn
(and (arrayp pass) (clear-string pass))
- (clear-string new-char)
- (setq c ?\0)
- (setq pass new-pass))
- (if (> (length pass) 0)
- (let ((new-pass (substring pass 0 -1)))
+ (setq pass ""))
+ (if (and (/= c ?\b) (/= c ?\177))
+ (let* ((new-char (char-to-string c))
+ (new-pass (concat pass new-char)))
(and (arrayp pass) (clear-string pass))
- (setq pass new-pass))))))
- (message nil)
- (or pass default ""))))
+ (clear-string new-char)
+ (setq c ?\0)
+ (setq pass new-pass))
+ (if (> (length pass) 0)
+ (let ((new-pass (substring pass 0 -1)))
+ (and (arrayp pass) (clear-string pass))
+ (setq pass new-pass))))))
+ (message nil)
+ (or pass default "")))))
;; This should be used by `call-interactively' for `n' specs.
(defun read-number (prompt &optional default)
This mechanism is transparent to ordinary use of undo;
if undo is enabled in the buffer and BODY succeeds, the
user can undo the change normally."
+ (declare (indent 0) (debug t))
(let ((handle (make-symbol "--change-group-handle--"))
(success (make-symbol "--change-group-success--")))
`(let ((,handle (prepare-change-group))
(when (and (consp elt) (not (eq elt (last pending-undo-list))))
(error "Undoing to some unrelated state"))
;; Undo it all.
- (while pending-undo-list (undo-more 1))
+ (while (listp pending-undo-list) (undo-more 1))
;; Reset the modified cons cell ELT to its original content.
(when (consp elt)
(setcar elt old-car)
;; Revert the undo info to what it was when we grabbed the state.
(setq buffer-undo-list elt)))))
\f
+;;;; Display-related functions.
+
;; For compatibility.
(defalias 'redraw-modeline 'force-mode-line-update)
\f
;;;; Miscellanea.
-;; A number of major modes set this locally.
-;; Give it a global value to avoid compiler warnings.
-(defvar font-lock-defaults nil)
-
(defvar suspend-hook nil
"Normal hook run by `suspend-emacs', before suspending.")
On those systems, it is automatically local in every buffer.
On other systems, this variable is normally always nil.")
-;; This should probably be written in C (i.e., without using `walk-windows').
-(defun get-buffer-window-list (buffer &optional minibuf frame)
- "Return list of all windows displaying BUFFER, or nil if none.
-BUFFER can be a buffer or a buffer name.
-See `walk-windows' for the meaning of MINIBUF and FRAME."
- (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows)
- (walk-windows (function (lambda (window)
- (if (eq (window-buffer window) buffer)
- (setq windows (cons window windows)))))
- minibuf frame)
- windows))
+;; The `assert' macro from the cl package signals
+;; `cl-assertion-failed' at runtime so always define it.
+(put 'cl-assertion-failed 'error-conditions '(error))
+(put 'cl-assertion-failed 'error-message "Assertion failed")
-(defun ignore (&rest ignore)
- "Do nothing and return nil.
-This function accepts any number of arguments, but ignores them."
- (interactive)
- nil)
+\f
+;;;; Misc. useful functions.
-(defun error (&rest args)
- "Signal an error, making error message by passing all args to `format'.
-In Emacs, the convention is that error messages start with a capital
-letter but *do not* end with a period. Please follow this convention
-for the sake of consistency."
- (while t
- (signal 'error (list (apply 'format args)))))
+(defun find-tag-default ()
+ "Determine default tag to search for, based on text at point.
+If there is no plausible default, return nil."
+ (save-excursion
+ (while (looking-at "\\sw\\|\\s_")
+ (forward-char 1))
+ (if (or (re-search-backward "\\sw\\|\\s_"
+ (save-excursion (beginning-of-line) (point))
+ t)
+ (re-search-forward "\\(\\sw\\|\\s_\\)+"
+ (save-excursion (end-of-line) (point))
+ t))
+ (progn
+ (goto-char (match-end 0))
+ (condition-case nil
+ (buffer-substring-no-properties
+ (point)
+ (progn (forward-sexp -1)
+ (while (looking-at "\\s'")
+ (forward-char 1))
+ (point)))
+ (error nil)))
+ nil)))
-(defalias 'user-original-login-name 'user-login-name)
+(defun play-sound (sound)
+ "SOUND is a list of the form `(sound KEYWORD VALUE...)'.
+The following keywords are recognized:
+
+ :file FILE - read sound data from FILE. If FILE isn't an
+absolute file name, it is searched in `data-directory'.
+
+ :data DATA - read sound data from string DATA.
+
+Exactly one of :file or :data must be present.
+
+ :volume VOL - set volume to VOL. VOL must an integer in the
+range 0..100 or a float in the range 0..1.0. If not specified,
+don't change the volume setting of the sound device.
+
+ :device DEVICE - play sound on DEVICE. If not specified,
+a system-dependent default device name is used."
+ (if (fboundp 'play-sound-internal)
+ (play-sound-internal sound)
+ (error "This Emacs binary lacks sound support")))
+
+(defun shell-quote-argument (argument)
+ "Quote an argument for passing as argument to an inferior shell."
+ (if (eq system-type 'ms-dos)
+ ;; Quote using double quotes, but escape any existing quotes in
+ ;; the argument with backslashes.
+ (let ((result "")
+ (start 0)
+ end)
+ (if (or (null (string-match "[^\"]" argument))
+ (< (match-end 0) (length argument)))
+ (while (string-match "[\"]" argument start)
+ (setq end (match-beginning 0)
+ result (concat result (substring argument start end)
+ "\\" (substring argument end (1+ end)))
+ start (1+ end))))
+ (concat "\"" result (substring argument start) "\""))
+ (if (eq system-type 'windows-nt)
+ (concat "\"" argument "\"")
+ (if (equal argument "")
+ "''"
+ ;; Quote everything except POSIX filename characters.
+ ;; This should be safe enough even for really weird shells.
+ (let ((result "") (start 0) end)
+ (while (string-match "[^-0-9a-zA-Z_./]" argument start)
+ (setq end (match-beginning 0)
+ result (concat result (substring argument start end)
+ "\\" (substring argument end (1+ end)))
+ start (1+ end)))
+ (concat result (substring argument start)))))))
+
+(defun string-or-null-p (object)
+ "Return t if OBJECT is a string or nil.
+Otherwise, return nil."
+ (or (stringp object) (null object)))
+
+(defun booleanp (object)
+ "Return non-nil if OBJECT is one of the two canonical boolean values: t or nil."
+ (memq object '(nil t)))
+
+\f
+;;;; Support for yanking and text properties.
(defvar yank-excluded-properties)
`yank-excluded-properties'. Otherwise just like (insert STRING).
If STRING has a non-nil `yank-handler' property on the first character,
-the normal insert behaviour is modified in various ways. The value of
-the yank-handler property must be a list with one to five elements
+the normal insert behavior is modified in various ways. The value of
+the yank-handler property must be a list with one to four elements
with the following format: (FUNCTION PARAM NOEXCLUDE UNDO).
When FUNCTION is present and non-nil, it is called instead of `insert'
to insert the string. FUNCTION takes one argument--the object to insert.
(remove-yank-excluded-properties opoint (point))))
\f
-;; Synchronous shell commands.
+;;;; Synchronous shell commands.
(defun start-process-shell-command (name buffer &rest args)
"Start a program in a subprocess. Return the process object for it.
shell-command-switch
(mapconcat 'identity (cons command args) " ")))))
\f
+;;;; Lisp macros to do various things temporarily.
+
(defmacro with-current-buffer (buffer &rest body)
"Execute the forms in BODY with BUFFER as the current buffer.
The value returned is the value of the last form in BODY.
(defmacro with-selected-window (window &rest body)
"Execute the forms in BODY with WINDOW as the selected window.
The value returned is the value of the last form in BODY.
-This does not alter the buffer list ordering.
-This function saves and restores the selected window, as well as
+
+This macro saves and restores the current buffer, since otherwise
+its normal operation could potentially make a different
+buffer current. It does not alter the buffer list ordering.
+
+This macro saves and restores the selected window, as well as
the selected window in each frame. If the previously selected
window of some frame is no longer live at the end of BODY, that
frame's selected window is left alone. If the selected window is
(save-selected-window-alist
(mapcar (lambda (frame) (list frame (frame-selected-window frame)))
(frame-list))))
- (unwind-protect
- (progn (select-window ,window 'norecord)
- ,@body)
- (dolist (elt save-selected-window-alist)
- (and (frame-live-p (car elt))
- (window-live-p (cadr elt))
- (set-frame-selected-window (car elt) (cadr elt))))
- (if (window-live-p save-selected-window-window)
- (select-window save-selected-window-window 'norecord)))))
+ (save-current-buffer
+ (unwind-protect
+ (progn (select-window ,window 'norecord)
+ ,@body)
+ (dolist (elt save-selected-window-alist)
+ (and (frame-live-p (car elt))
+ (window-live-p (cadr elt))
+ (set-frame-selected-window (car elt) (cadr elt))))
+ (if (window-live-p save-selected-window-window)
+ (select-window save-selected-window-window 'norecord))))))
(defmacro with-temp-file (file &rest body)
"Create a new buffer, evaluate BODY there, and write the buffer to FILE.
See also `with-temp-file' and `with-output-to-string'."
(declare (indent 0) (debug t))
(let ((temp-buffer (make-symbol "temp-buffer")))
- `(let ((,temp-buffer
- (get-buffer-create (generate-new-buffer-name " *temp*"))))
+ `(let ((,temp-buffer (generate-new-buffer " *temp*")))
(unwind-protect
(with-current-buffer ,temp-buffer
,@body)
(defmacro with-local-quit (&rest body)
"Execute BODY, allowing quits to terminate BODY but not escape further.
-When a quit terminates BODY, `with-local-quit' requests another quit when
-it finishes. That quit will be processed in turn, the next time quitting
-is again allowed."
+When a quit terminates BODY, `with-local-quit' returns nil but
+requests another quit. That quit will be processed, the next time quitting
+is allowed once again."
(declare (debug t) (indent 0))
`(condition-case nil
(let ((inhibit-quit nil))
,@body)
- (quit (setq quit-flag t))))
+ (quit (setq quit-flag t) nil)))
+
+(defmacro while-no-input (&rest body)
+ "Execute BODY only as long as there's no pending input.
+If input arrives, that ends the execution of BODY,
+and `while-no-input' returns t. Quitting makes it return nil.
+If BODY finishes, `while-no-input' returns whatever value BODY produced."
+ (declare (debug t) (indent 0))
+ (let ((catch-sym (make-symbol "input")))
+ `(with-local-quit
+ (catch ',catch-sym
+ (let ((throw-on-input ',catch-sym))
+ (or (not (sit-for 0 0 t))
+ ,@body))))))
(defmacro combine-after-change-calls (&rest body)
"Execute BODY, but don't call the after-change functions till the end.
(let ((combine-after-change-calls t))
. ,body)
(combine-after-change-execute)))
+\f
+;;;; Constructing completion tables.
-
-(defvar delay-mode-hooks nil
- "If non-nil, `run-mode-hooks' should delay running the hooks.")
-(defvar delayed-mode-hooks nil
- "List of delayed mode hooks waiting to be run.")
-(make-variable-buffer-local 'delayed-mode-hooks)
-(put 'delay-mode-hooks 'permanent-local t)
-
-(defvar after-change-major-mode-hook nil
- "Mode independent hook run at the end of major mode functions.
-This is run just before the mode dependent hooks.")
-
-(defun run-mode-hooks (&rest hooks)
- "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
-Execution is delayed if `delay-mode-hooks' is non-nil.
-Major mode functions should use this."
- (if delay-mode-hooks
- ;; Delaying case.
- (dolist (hook hooks)
- (push hook delayed-mode-hooks))
- ;; Normal case, just run the hook as before plus any delayed hooks.
- (setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
- (setq delayed-mode-hooks nil)
- (run-hooks 'after-change-major-mode-hook)
- (apply 'run-hooks hooks)))
-
-(defmacro delay-mode-hooks (&rest body)
- "Execute BODY, but delay any `run-mode-hooks'.
-Only affects hooks run in the current buffer."
- (declare (debug t))
- `(progn
- (make-local-variable 'delay-mode-hooks)
- (let ((delay-mode-hooks t))
- ,@body)))
-
-;; PUBLIC: find if the current mode derives from another.
-
-(defun derived-mode-p (&rest modes)
- "Non-nil if the current major mode is derived from one of MODES.
-Uses the `derived-mode-parent' property of the symbol to trace backwards."
- (let ((parent major-mode))
- (while (and (not (memq parent modes))
- (setq parent (get parent 'derived-mode-parent))))
- parent))
-
-(defun find-tag-default ()
- "Determine default tag to search for, based on text at point.
-If there is no plausible default, return nil."
- (save-excursion
- (while (looking-at "\\sw\\|\\s_")
- (forward-char 1))
- (if (or (re-search-backward "\\sw\\|\\s_"
- (save-excursion (beginning-of-line) (point))
- t)
- (re-search-forward "\\(\\sw\\|\\s_\\)+"
- (save-excursion (end-of-line) (point))
- t))
- (progn (goto-char (match-end 0))
- (buffer-substring-no-properties
- (point)
- (progn (forward-sexp -1)
- (while (looking-at "\\s'")
- (forward-char 1))
- (point))))
- nil)))
-
-(defmacro with-syntax-table (table &rest body)
- "Evaluate BODY with syntax table of current buffer set to TABLE.
-The syntax table of the current buffer is saved, BODY is evaluated, and the
-saved table is restored, even in case of an abnormal exit.
-Value is what BODY returns."
- (declare (debug t))
- (let ((old-table (make-symbol "table"))
- (old-buffer (make-symbol "buffer")))
- `(let ((,old-table (syntax-table))
- (,old-buffer (current-buffer)))
- (unwind-protect
- (progn
- (set-syntax-table ,table)
- ,@body)
- (save-current-buffer
- (set-buffer ,old-buffer)
- (set-syntax-table ,old-table))))))
-
-(defmacro dynamic-completion-table (fun)
- "Use function FUN as a dynamic completion table.
-FUN is called with one argument, the string for which completion is required,
-and it should return an alist containing all the intended possible
-completions. This alist may be a full list of possible completions so that FUN
-can ignore the value of its argument. If completion is performed in the
-minibuffer, FUN will be called in the buffer from which the minibuffer was
-entered.
+(defmacro dynamic-completion-table (fun)
+ "Use function FUN as a dynamic completion table.
+FUN is called with one argument, the string for which completion is required,
+and it should return an alist containing all the intended possible
+completions. This alist may be a full list of possible completions so that FUN
+can ignore the value of its argument. If completion is performed in the
+minibuffer, FUN will be called in the buffer from which the minibuffer was
+entered.
The result of the `dynamic-completion-table' form is a function
that can be used as the ALIST argument to `try-completion' and
`all-completion'. See Info node `(elisp)Programmed Completion'."
+ (declare (debug (lambda-expr)))
(let ((win (make-symbol "window"))
(string (make-symbol "string"))
(predicate (make-symbol "predicate"))
((not ,mode) (try-completion ,string (,fun ,string) ,predicate))
(t (test-completion ,string (,fun ,string) ,predicate)))))))
-(defmacro lazy-completion-table (var fun &rest args)
+(defmacro lazy-completion-table (var fun)
+ ;; We used to have `&rest args' where `args' were evaluated late (at the
+ ;; time of the call to `fun'), which was counter intuitive. But to get
+ ;; them to be evaluated early, we have to either use lexical-let (which is
+ ;; not available in subr.el) or use `(lambda (,str) ...) which prevents the use
+ ;; of lexical-let in the callers.
+ ;; So we just removed the argument. Callers can then simply use either of:
+ ;; (lazy-completion-table var (lambda () (fun x y)))
+ ;; or
+ ;; (lazy-completion-table var `(lambda () (fun ',x ',y)))
+ ;; or
+ ;; (lexical-let ((x x)) ((y y))
+ ;; (lazy-completion-table var (lambda () (fun x y))))
+ ;; depending on the behavior they want.
"Initialize variable VAR as a lazy completion table.
If the completion table VAR is used for the first time (e.g., by passing VAR
-as an argument to `try-completion'), the function FUN is called with arguments
-ARGS. FUN must return the completion table that will be stored in VAR.
+as an argument to `try-completion'), the function FUN is called with no
+arguments. FUN must return the completion table that will be stored in VAR.
If completion is requested in the minibuffer, FUN will be called in the buffer
from which the minibuffer was entered. The return value of
-`lazy-completion-table' must be used to initialize the value of VAR."
+`lazy-completion-table' must be used to initialize the value of VAR.
+
+You should give VAR a non-nil `risky-local-variable' property."
+ (declare (debug (symbol lambda-expr)))
(let ((str (make-symbol "string")))
`(dynamic-completion-table
(lambda (,str)
- (unless (listp ,var)
- (setq ,var (funcall ',fun ,@args)))
+ (when (functionp ,var)
+ (setq ,var (,fun)))
,var))))
+
+(defmacro complete-in-turn (a b)
+ "Create a completion table that first tries completion in A and then in B.
+A and B should not be costly (or side-effecting) expressions."
+ (declare (debug (def-form def-form)))
+ `(lambda (string predicate mode)
+ (cond
+ ((eq mode t)
+ (or (all-completions string ,a predicate)
+ (all-completions string ,b predicate)))
+ ((eq mode nil)
+ (or (try-completion string ,a predicate)
+ (try-completion string ,b predicate)))
+ (t
+ (or (test-completion string ,a predicate)
+ (test-completion string ,b predicate))))))
\f
-;;; Matching and substitution
+;;; Matching and match data.
(defvar save-match-data-internal)
'((save-match-data-internal (match-data)))
(list 'unwind-protect
(cons 'progn body)
- '(set-match-data save-match-data-internal))))
+ ;; It is safe to free (evaporate) markers immediately here,
+ ;; as Lisp programs should not copy from save-match-data-internal.
+ '(set-match-data save-match-data-internal 'evaporate))))
(defun match-string (num &optional string)
"Return string of text matched by last search.
(buffer-substring-no-properties (match-beginning num)
(match-end num)))))
-(defun looking-back (regexp &optional limit)
+(defun looking-back (regexp &optional limit greedy)
"Return non-nil if text before point matches regular expression REGEXP.
-Like `looking-at' except backwards and slower.
+Like `looking-at' except matches before point, and is slower.
LIMIT if non-nil speeds up the search by specifying how far back the
-match can start."
- (save-excursion
- (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)))
+match can start.
+
+If GREEDY is non-nil, extend the match backwards as far as possible,
+stopping when a single additional previous character cannot be part
+of a match for REGEXP."
+ (let ((start (point))
+ (pos
+ (save-excursion
+ (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)
+ (point)))))
+ (if (and greedy pos)
+ (save-restriction
+ (narrow-to-region (point-min) start)
+ (while (and (> pos (point-min))
+ (save-excursion
+ (goto-char pos)
+ (backward-char 1)
+ (looking-at (concat "\\(?:" regexp "\\)\\'"))))
+ (setq pos (1- pos)))
+ (save-excursion
+ (goto-char pos)
+ (looking-at (concat "\\(?:" regexp "\\)\\'")))))
+ (not (null pos))))
+
+(defun subregexp-context-p (regexp pos &optional start)
+ "Return non-nil if POS is in a normal subregexp context in REGEXP.
+A subregexp context is one where a sub-regexp can appear.
+A non-subregexp context is for example within brackets, or within a
+repetition bounds operator `\\=\\{...\\}', or right after a `\\'.
+If START is non-nil, it should be a position in REGEXP, smaller
+than POS, and known to be in a subregexp context."
+ ;; Here's one possible implementation, with the great benefit that it
+ ;; reuses the regexp-matcher's own parser, so it understands all the
+ ;; details of the syntax. A disadvantage is that it needs to match the
+ ;; error string.
+ (condition-case err
+ (progn
+ (string-match (substring regexp (or start 0) pos) "")
+ t)
+ (invalid-regexp
+ (not (member (cadr err) '("Unmatched [ or [^"
+ "Unmatched \\{"
+ "Trailing backslash")))))
+ ;; An alternative implementation:
+ ;; (defconst re-context-re
+ ;; (let* ((harmless-ch "[^\\[]")
+ ;; (harmless-esc "\\\\[^{]")
+ ;; (class-harmless-ch "[^][]")
+ ;; (class-lb-harmless "[^]:]")
+ ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?")
+ ;; (class-lb (concat "\\[\\(" class-lb-harmless
+ ;; "\\|" class-lb-colon-maybe-charclass "\\)"))
+ ;; (class
+ ;; (concat "\\[^?]?"
+ ;; "\\(" class-harmless-ch
+ ;; "\\|" class-lb "\\)*"
+ ;; "\\[?]")) ; special handling for bare [ at end of re
+ ;; (braces "\\\\{[0-9,]+\\\\}"))
+ ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc
+ ;; "\\|" class "\\|" braces "\\)*\\'"))
+ ;; "Matches any prefix that corresponds to a normal subregexp context.")
+ ;; (string-match re-context-re (substring regexp (or start 0) pos))
+ )
+\f
+;;;; split-string
(defconst split-string-default-separators "[ \f\t\n\r\v]+"
"The default value of separators for `split-string'.
(cons (substring string start)
list)))
(nreverse list)))
+\f
+;;;; Replacement in strings.
(defun subst-char-in-string (fromchar tochar string &optional inplace)
"Replace FROMCHAR with TOCHAR in STRING each time it occurs.
is non-nil, start replacements at that index in STRING.
REP is either a string used as the NEWTEXT arg of `replace-match' or a
-function. If it is a function it is applied to each match to generate
-the replacement passed to `replace-match'; the match-data at this
-point are such that match 0 is the function's argument.
+function. If it is a function, it is called with the actual text of each
+match, and its value is used as the replacement text. When REP is called,
+the match-data are the result of matching REGEXP against a substring
+of STRING.
To replace only the first match (if any), make REGEXP match up to \\'
and replace a sub-expression, e.g.
(setq matches (cons (substring string start l) matches)) ; leftover
(apply #'concat (nreverse matches)))))
\f
-(defun shell-quote-argument (argument)
- "Quote an argument for passing as argument to an inferior shell."
- (if (eq system-type 'ms-dos)
- ;; Quote using double quotes, but escape any existing quotes in
- ;; the argument with backslashes.
- (let ((result "")
- (start 0)
- end)
- (if (or (null (string-match "[^\"]" argument))
- (< (match-end 0) (length argument)))
- (while (string-match "[\"]" argument start)
- (setq end (match-beginning 0)
- result (concat result (substring argument start end)
- "\\" (substring argument end (1+ end)))
- start (1+ end))))
- (concat "\"" result (substring argument start) "\""))
- (if (eq system-type 'windows-nt)
- (concat "\"" argument "\"")
- (if (equal argument "")
- "''"
- ;; Quote everything except POSIX filename characters.
- ;; This should be safe enough even for really weird shells.
- (let ((result "") (start 0) end)
- (while (string-match "[^-0-9a-zA-Z_./]" argument start)
- (setq end (match-beginning 0)
- result (concat result (substring argument start end)
- "\\" (substring argument end (1+ end)))
- start (1+ end)))
- (concat result (substring argument start)))))))
+;;;; invisibility specs
+
+(defun add-to-invisibility-spec (element)
+ "Add ELEMENT to `buffer-invisibility-spec'.
+See documentation for `buffer-invisibility-spec' for the kind of elements
+that can be added."
+ (if (eq buffer-invisibility-spec t)
+ (setq buffer-invisibility-spec (list t)))
+ (setq buffer-invisibility-spec
+ (cons element buffer-invisibility-spec)))
+
+(defun remove-from-invisibility-spec (element)
+ "Remove ELEMENT from `buffer-invisibility-spec'."
+ (if (consp buffer-invisibility-spec)
+ (setq buffer-invisibility-spec (delete element buffer-invisibility-spec))))
+\f
+;;;; Syntax tables.
+
+(defmacro with-syntax-table (table &rest body)
+ "Evaluate BODY with syntax table of current buffer set to TABLE.
+The syntax table of the current buffer is saved, BODY is evaluated, and the
+saved table is restored, even in case of an abnormal exit.
+Value is what BODY returns."
+ (declare (debug t))
+ (let ((old-table (make-symbol "table"))
+ (old-buffer (make-symbol "buffer")))
+ `(let ((,old-table (syntax-table))
+ (,old-buffer (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-syntax-table ,table)
+ ,@body)
+ (save-current-buffer
+ (set-buffer ,old-buffer)
+ (set-syntax-table ,old-table))))))
(defun make-syntax-table (&optional oldtable)
"Return a new syntax table.
table))
(defun syntax-after (pos)
- "Return the syntax of the char after POS."
+ "Return the raw syntax of the char after POS.
+If POS is outside the buffer's accessible portion, return nil."
(unless (or (< pos (point-min)) (>= pos (point-max)))
(let ((st (if parse-sexp-lookup-properties
(get-char-property pos 'syntax-table))))
(if (consp st) st
(aref (or st (syntax-table)) (char-after pos))))))
-(defun add-to-invisibility-spec (arg)
- "Add elements to `buffer-invisibility-spec'.
-See documentation for `buffer-invisibility-spec' for the kind of elements
-that can be added."
- (if (eq buffer-invisibility-spec t)
- (setq buffer-invisibility-spec (list t)))
- (setq buffer-invisibility-spec
- (cons arg buffer-invisibility-spec)))
-
-(defun remove-from-invisibility-spec (arg)
- "Remove elements from `buffer-invisibility-spec'."
- (if (consp buffer-invisibility-spec)
- (setq buffer-invisibility-spec (delete arg buffer-invisibility-spec))))
+(defun syntax-class (syntax)
+ "Return the syntax class part of the syntax descriptor SYNTAX.
+If SYNTAX is nil, return nil."
+ (and syntax (logand (car syntax) 65535)))
\f
-(defun global-set-key (key command)
- "Give KEY a global binding as COMMAND.
-COMMAND is the command definition to use; usually it is
-a symbol naming an interactively-callable function.
-KEY is a key sequence; noninteractively, it is a string or vector
-of characters or event types, and non-ASCII characters with codes
-above 127 (such as ISO Latin-1) can be included if you use a vector.
-
-Note that if KEY has a local binding in the current buffer,
-that local binding will continue to shadow any global binding
-that you make with this function."
- (interactive "KSet key globally: \nCSet key %s to command: ")
- (or (vectorp key) (stringp key)
- (signal 'wrong-type-argument (list 'arrayp key)))
- (define-key (current-global-map) key command))
-
-(defun local-set-key (key command)
- "Give KEY a local binding as COMMAND.
-COMMAND is the command definition to use; usually it is
-a symbol naming an interactively-callable function.
-KEY is a key sequence; noninteractively, it is a string or vector
-of characters or event types, and non-ASCII characters with codes
-above 127 (such as ISO Latin-1) can be included if you use a vector.
-
-The binding goes in the current buffer's local map,
-which in most cases is shared with all other buffers in the same major mode."
- (interactive "KSet key locally: \nCSet key %s locally to command: ")
- (let ((map (current-local-map)))
- (or map
- (use-local-map (setq map (make-sparse-keymap))))
- (or (vectorp key) (stringp key)
- (signal 'wrong-type-argument (list 'arrayp key)))
- (define-key map key command)))
-
-(defun global-unset-key (key)
- "Remove global binding of KEY.
-KEY is a string or vector representing a sequence of keystrokes."
- (interactive "kUnset key globally: ")
- (global-set-key key nil))
-
-(defun local-unset-key (key)
- "Remove local binding of KEY.
-KEY is a string or vector representing a sequence of keystrokes."
- (interactive "kUnset key locally: ")
- (if (current-local-map)
- (local-set-key key nil))
- nil)
-\f
-;; We put this here instead of in frame.el so that it's defined even on
-;; systems where frame.el isn't loaded.
-(defun frame-configuration-p (object)
- "Return non-nil if OBJECT seems to be a frame configuration.
-Any list whose car is `frame-configuration' is assumed to be a frame
-configuration."
- (and (consp object)
- (eq (car object) 'frame-configuration)))
-
-(defun functionp (object)
- "Non-nil if OBJECT is any kind of function or a special form.
-Also non-nil if OBJECT is a symbol and its function definition is
-\(recursively) a function or special form. This does not include
-macros."
- (or (and (symbolp object) (fboundp object)
- (condition-case nil
- (setq object (indirect-function object))
- (error nil))
- (eq (car-safe object) 'autoload)
- (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
- (subrp object) (byte-code-function-p object)
- (eq (car-safe object) 'lambda)))
-
-(defun assq-delete-all (key alist)
- "Delete from ALIST all elements whose car is KEY.
-Return the modified alist.
-Elements of ALIST that are not conses are ignored."
- (let ((tail alist))
- (while tail
- (if (and (consp (car tail)) (eq (car (car tail)) key))
- (setq alist (delq (car tail) alist)))
- (setq tail (cdr tail)))
- alist))
-
-(defun make-temp-file (prefix &optional dir-flag suffix)
- "Create a temporary file.
-The returned file name (created by appending some random characters at the end
-of PREFIX, and expanding against `temporary-file-directory' if necessary),
-is guaranteed to point to a newly created empty file.
-You can then use `write-region' to write new data into the file.
-
-If DIR-FLAG is non-nil, create a new empty directory instead of a file.
-
-If SUFFIX is non-nil, add that at the end of the file name."
- (let ((umask (default-file-modes))
- file)
- (unwind-protect
- (progn
- ;; Create temp files with strict access rights. It's easy to
- ;; loosen them later, whereas it's impossible to close the
- ;; time-window of loose permissions otherwise.
- (set-default-file-modes ?\700)
- (while (condition-case ()
- (progn
- (setq file
- (make-temp-name
- (expand-file-name prefix temporary-file-directory)))
- (if suffix
- (setq file (concat file suffix)))
- (if dir-flag
- (make-directory file)
- (write-region "" nil file nil 'silent nil 'excl))
- nil)
- (file-already-exists t))
- ;; the file was somehow created by someone else between
- ;; `make-temp-name' and `write-region', let's try again.
- nil)
- file)
- ;; Reset the umask.
- (set-default-file-modes umask))))
-
-\f
-;; If a minor mode is not defined with define-minor-mode,
-;; add it here explicitly.
-;; isearch-mode is deliberately excluded, since you should
-;; not call it yourself.
-(defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode
- overwrite-mode view-mode
- hs-minor-mode)
- "List of all minor mode functions.")
-
-(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
- "Register a new minor mode.
-
-This is an XEmacs-compatibility function. Use `define-minor-mode' instead.
-
-TOGGLE is a symbol which is the name of a buffer-local variable that
-is toggled on or off to say whether the minor mode is active or not.
-
-NAME specifies what will appear in the mode line when the minor mode
-is active. NAME should be either a string starting with a space, or a
-symbol whose value is such a string.
-
-Optional KEYMAP is the keymap for the minor mode that will be added
-to `minor-mode-map-alist'.
-
-Optional AFTER specifies that TOGGLE should be added after AFTER
-in `minor-mode-alist'.
-
-Optional TOGGLE-FUN is an interactive function to toggle the mode.
-It defaults to (and should by convention be) TOGGLE.
-
-If TOGGLE has a non-nil `:included' property, an entry for the mode is
-included in the mode-line minor mode menu.
-If TOGGLE has a `:menu-tag', that is used for the menu item's label."
- (unless (memq toggle minor-mode-list)
- (push toggle minor-mode-list))
-
- (unless toggle-fun (setq toggle-fun toggle))
- ;; Add the name to the minor-mode-alist.
- (when name
- (let ((existing (assq toggle minor-mode-alist)))
- (if existing
- (setcdr existing (list name))
- (let ((tail minor-mode-alist) found)
- (while (and tail (not found))
- (if (eq after (caar tail))
- (setq found tail)
- (setq tail (cdr tail))))
- (if found
- (let ((rest (cdr found)))
- (setcdr found nil)
- (nconc found (list (list toggle name)) rest))
- (setq minor-mode-alist (cons (list toggle name)
- minor-mode-alist)))))))
- ;; Add the toggle to the minor-modes menu if requested.
- (when (get toggle :included)
- (define-key mode-line-mode-menu
- (vector toggle)
- (list 'menu-item
- (concat
- (or (get toggle :menu-tag)
- (if (stringp name) name (symbol-name toggle)))
- (let ((mode-name (if (symbolp name) (symbol-value name))))
- (if (and (stringp mode-name) (string-match "[^ ]+" mode-name))
- (concat " (" (match-string 0 mode-name) ")"))))
- toggle-fun
- :button (cons :toggle toggle))))
-
- ;; Add the map to the minor-mode-map-alist.
- (when keymap
- (let ((existing (assq toggle minor-mode-map-alist)))
- (if existing
- (setcdr existing keymap)
- (let ((tail minor-mode-map-alist) found)
- (while (and tail (not found))
- (if (eq after (caar tail))
- (setq found tail)
- (setq tail (cdr tail))))
- (if found
- (let ((rest (cdr found)))
- (setcdr found nil)
- (nconc found (list (cons toggle keymap)) rest))
- (setq minor-mode-map-alist (cons (cons toggle keymap)
- minor-mode-map-alist))))))))
-\f
-;; Clones ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Text clones
(defun text-clone-maintain (ol1 after beg end &optional len)
"Propagate the changes made under the overlay OL1 to the other clones.
;;(overlay-put ol2 'face 'underline)
(overlay-put ol2 'evaporate t)
(overlay-put ol2 'text-clones dups)))
+\f
+;;;; Mail user agents.
-(defun play-sound (sound)
- "SOUND is a list of the form `(sound KEYWORD VALUE...)'.
-The following keywords are recognized:
-
- :file FILE - read sound data from FILE. If FILE isn't an
-absolute file name, it is searched in `data-directory'.
-
- :data DATA - read sound data from string DATA.
-
-Exactly one of :file or :data must be present.
-
- :volume VOL - set volume to VOL. VOL must an integer in the
-range 0..100 or a float in the range 0..1.0. If not specified,
-don't change the volume setting of the sound device.
-
- :device DEVICE - play sound on DEVICE. If not specified,
-a system-dependent default device name is used."
- (unless (fboundp 'play-sound-internal)
- (error "This Emacs binary lacks sound support"))
- (play-sound-internal sound))
+;; Here we include just enough for other packages to be able
+;; to define them.
(defun define-mail-user-agent (symbol composefunc sendfunc
&optional abortfunc hookvar)
(put symbol 'sendfunc sendfunc)
(put symbol 'abortfunc (or abortfunc 'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
+\f
+;;;; Progress reporters.
+
+;; Progress reporter has the following structure:
+;;
+;; (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME
+;; MIN-VALUE
+;; MAX-VALUE
+;; MESSAGE
+;; MIN-CHANGE
+;; MIN-TIME])
+;;
+;; This weirdeness is for optimization reasons: we want
+;; `progress-reporter-update' to be as fast as possible, so
+;; `(car reporter)' is better than `(aref reporter 0)'.
+;;
+;; NEXT-UPDATE-TIME is a float. While `float-time' loses a couple
+;; digits of precision, it doesn't really matter here. On the other
+;; hand, it greatly simplifies the code.
+
+(defsubst progress-reporter-update (reporter value)
+ "Report progress of an operation in the echo area.
+However, if the change since last echo area update is too small
+or not enough time has passed, then do nothing (see
+`make-progress-reporter' for details).
+
+First parameter, REPORTER, should be the result of a call to
+`make-progress-reporter'. Second, VALUE, determines the actual
+progress of operation; it must be between MIN-VALUE and MAX-VALUE
+as passed to `make-progress-reporter'.
+
+This function is very inexpensive, you may not bother how often
+you call it."
+ (when (>= value (car reporter))
+ (progress-reporter-do-update reporter value)))
+
+(defun make-progress-reporter (message min-value max-value
+ &optional current-value
+ min-change min-time)
+ "Return progress reporter object to be used with `progress-reporter-update'.
+
+MESSAGE is shown in the echo area. When at least 1% of operation
+is complete, the exact percentage will be appended to the
+MESSAGE. When you call `progress-reporter-done', word \"done\"
+is printed after the MESSAGE. You can change MESSAGE of an
+existing progress reporter with `progress-reporter-force-update'.
+
+MIN-VALUE and MAX-VALUE designate starting (0% complete) and
+final (100% complete) states of operation. The latter should be
+larger; if this is not the case, then simply negate all values.
+Optional CURRENT-VALUE specifies the progress by the moment you
+call this function. You should omit it or set it to nil in most
+cases since it defaults to MIN-VALUE.
+
+Optional MIN-CHANGE determines the minimal change in percents to
+report (default is 1%.) Optional MIN-TIME specifies the minimal
+time before echo area updates (default is 0.2 seconds.) If
+`float-time' function is not present, then time is not tracked
+at all. If OS is not capable of measuring fractions of seconds,
+then this parameter is effectively rounded up."
+
+ (unless min-time
+ (setq min-time 0.2))
+ (let ((reporter
+ (cons min-value ;; Force a call to `message' now
+ (vector (if (and (fboundp 'float-time)
+ (>= min-time 0.02))
+ (float-time) nil)
+ min-value
+ max-value
+ message
+ (if min-change (max (min min-change 50) 1) 1)
+ min-time))))
+ (progress-reporter-update reporter (or current-value min-value))
+ reporter))
+
+(defun progress-reporter-force-update (reporter value &optional new-message)
+ "Report progress of an operation in the echo area unconditionally.
+
+First two parameters are the same as for
+`progress-reporter-update'. Optional NEW-MESSAGE allows you to
+change the displayed message."
+ (let ((parameters (cdr reporter)))
+ (when new-message
+ (aset parameters 3 new-message))
+ (when (aref parameters 0)
+ (aset parameters 0 (float-time)))
+ (progress-reporter-do-update reporter value)))
+
+(defun progress-reporter-do-update (reporter value)
+ (let* ((parameters (cdr reporter))
+ (min-value (aref parameters 1))
+ (max-value (aref parameters 2))
+ (one-percent (/ (- max-value min-value) 100.0))
+ (percentage (if (= max-value min-value)
+ 0
+ (truncate (/ (- value min-value) one-percent))))
+ (update-time (aref parameters 0))
+ (current-time (float-time))
+ (enough-time-passed
+ ;; See if enough time has passed since the last update.
+ (or (not update-time)
+ (when (>= current-time update-time)
+ ;; Calculate time for the next update
+ (aset parameters 0 (+ update-time (aref parameters 5)))))))
+ ;;
+ ;; Calculate NEXT-UPDATE-VALUE. If we are not going to print
+ ;; message this time because not enough time has passed, then use
+ ;; 1 instead of MIN-CHANGE. This makes delays between echo area
+ ;; updates closer to MIN-TIME.
+ (setcar reporter
+ (min (+ min-value (* (+ percentage
+ (if enough-time-passed
+ (aref parameters 4) ;; MIN-CHANGE
+ 1))
+ one-percent))
+ max-value))
+ (when (integerp value)
+ (setcar reporter (ceiling (car reporter))))
+ ;;
+ ;; Only print message if enough time has passed
+ (when enough-time-passed
+ (if (> percentage 0)
+ (message "%s%d%%" (aref parameters 3) percentage)
+ (message "%s" (aref parameters 3))))))
+
+(defun progress-reporter-done (reporter)
+ "Print reporter's message followed by word \"done\" in echo area."
+ (message "%sdone" (aref (cdr reporter) 3)))
+
+(defmacro dotimes-with-progress-reporter (spec message &rest body)
+ "Loop a certain number of times and report progress in the echo area.
+Evaluate BODY with VAR bound to successive integers running from
+0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get
+the return value (nil if RESULT is omitted).
+
+At each iteration MESSAGE followed by progress percentage is
+printed in the echo area. After the loop is finished, MESSAGE
+followed by word \"done\" is printed. This macro is a
+convenience wrapper around `make-progress-reporter' and friends.
+
+\(fn (VAR COUNT [RESULT]) MESSAGE BODY...)"
+ (declare (indent 2) (debug ((symbolp form &optional form) form body)))
+ (let ((temp (make-symbol "--dotimes-temp--"))
+ (temp2 (make-symbol "--dotimes-temp2--"))
+ (start 0)
+ (end (nth 1 spec)))
+ `(let ((,temp ,end)
+ (,(car spec) ,start)
+ (,temp2 (make-progress-reporter ,message ,start ,end)))
+ (while (< ,(car spec) ,temp)
+ ,@body
+ (progress-reporter-update ,temp2
+ (setq ,(car spec) (1+ ,(car spec)))))
+ (progress-reporter-done ,temp2)
+ nil ,@(cdr (cdr spec)))))
+
+\f
+;;;; Comparing version strings.
+
+(defvar version-separator "."
+ "*Specify the string used to separate the version elements.
+
+Usually the separator is \".\", but it can be any other string.")
+
+
+(defvar version-regexp-alist
+ '(("^[-_+ ]?a\\(lpha\\)?$" . -3)
+ ("^[-_+]$" . -3) ; treat "1.2.3-20050920" and "1.2-3" as alpha releases
+ ("^[-_+ ]cvs$" . -3) ; treat "1.2.3-CVS" as alpha release
+ ("^[-_+ ]?b\\(eta\\)?$" . -2)
+ ("^[-_+ ]?\\(pre\\|rc\\)$" . -1))
+ "*Specify association between non-numeric version part and a priority.
+
+This association is used to handle version string like \"1.0pre2\",
+\"0.9alpha1\", etc. It's used by `version-to-list' (which see) to convert the
+non-numeric part to an integer. For example:
+
+ String Version Integer List Version
+ \"1.0pre2\" (1 0 -1 2)
+ \"1.0PRE2\" (1 0 -1 2)
+ \"22.8beta3\" (22 8 -2 3)
+ \"22.8 Beta3\" (22 8 -2 3)
+ \"0.9alpha1\" (0 9 -3 1)
+ \"0.9AlphA1\" (0 9 -3 1)
+ \"0.9 alpha\" (0 9 -3)
+
+Each element has the following form:
+
+ (REGEXP . PRIORITY)
+
+Where:
+
+REGEXP regexp used to match non-numeric part of a version string.
+ It should begin with a `^' anchor and end with a `$' to
+ prevent false hits. Letter-case is ignored while matching
+ REGEXP.
+
+PRIORITY negative integer which indicate the non-numeric priority.")
+
+
+(defun version-to-list (ver)
+ "Convert version string VER into an integer list.
+
+The version syntax is given by the following EBNF:
+
+ VERSION ::= NUMBER ( SEPARATOR NUMBER )*.
+
+ NUMBER ::= (0|1|2|3|4|5|6|7|8|9)+.
+
+ SEPARATOR ::= `version-separator' (which see)
+ | `version-regexp-alist' (which see).
+
+The NUMBER part is optional if SEPARATOR is a match for an element
+in `version-regexp-alist'.
+
+As an example of valid version syntax:
+
+ 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1 6.9.30Beta
+
+As an example of invalid version syntax:
+
+ 1.0prepre2 1.0..7.5 22.8X3 alpha3.2 .5
+
+As an example of version convertion:
+
+ String Version Integer List Version
+ \"1.0.7.5\" (1 0 7 5)
+ \"1.0pre2\" (1 0 -1 2)
+ \"1.0PRE2\" (1 0 -1 2)
+ \"22.8beta3\" (22 8 -2 3)
+ \"22.8Beta3\" (22 8 -2 3)
+ \"0.9alpha1\" (0 9 -3 1)
+ \"0.9AlphA1\" (0 9 -3 1)
+ \"0.9alpha\" (0 9 -3)
+
+See documentation for `version-separator' and `version-regexp-alist'."
+ (or (and (stringp ver) (> (length ver) 0))
+ (error "Invalid version string: '%s'" ver))
+ ;; Change .x.y to 0.x.y
+ (if (and (>= (length ver) (length version-separator))
+ (string-equal (substring ver 0 (length version-separator))
+ version-separator))
+ (setq ver (concat "0" ver)))
+ (save-match-data
+ (let ((i 0)
+ (case-fold-search t) ; ignore case in matching
+ lst s al)
+ (while (and (setq s (string-match "[0-9]+" ver i))
+ (= s i))
+ ;; handle numeric part
+ (setq lst (cons (string-to-number (substring ver i (match-end 0)))
+ lst)
+ i (match-end 0))
+ ;; handle non-numeric part
+ (when (and (setq s (string-match "[^0-9]+" ver i))
+ (= s i))
+ (setq s (substring ver i (match-end 0))
+ i (match-end 0))
+ ;; handle alpha, beta, pre, etc. separator
+ (unless (string= s version-separator)
+ (setq al version-regexp-alist)
+ (while (and al (not (string-match (caar al) s)))
+ (setq al (cdr al)))
+ (or al (error "Invalid version syntax: '%s'" ver))
+ (setq lst (cons (cdar al) lst)))))
+ (if (null lst)
+ (error "Invalid version syntax: '%s'" ver)
+ (nreverse lst)))))
+
+
+(defun version-list-< (l1 l2)
+ "Return t if integer list L1 is lesser than L2.
+
+Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
+etc. That is, the trailing zeroes are irrelevant. Also, integer
+list (1) is greater than (1 -1) which is greater than (1 -2)
+which is greater than (1 -3)."
+ (while (and l1 l2 (= (car l1) (car l2)))
+ (setq l1 (cdr l1)
+ l2 (cdr l2)))
+ (cond
+ ;; l1 not null and l2 not null
+ ((and l1 l2) (< (car l1) (car l2)))
+ ;; l1 null and l2 null ==> l1 length = l2 length
+ ((and (null l1) (null l2)) nil)
+ ;; l1 not null and l2 null ==> l1 length > l2 length
+ (l1 (< (version-list-not-zero l1) 0))
+ ;; l1 null and l2 not null ==> l2 length > l1 length
+ (t (< 0 (version-list-not-zero l2)))))
+
+
+(defun version-list-= (l1 l2)
+ "Return t if integer list L1 is equal to L2.
+
+Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
+etc. That is, the trailing zeroes are irrelevant. Also, integer
+list (1) is greater than (1 -1) which is greater than (1 -2)
+which is greater than (1 -3)."
+ (while (and l1 l2 (= (car l1) (car l2)))
+ (setq l1 (cdr l1)
+ l2 (cdr l2)))
+ (cond
+ ;; l1 not null and l2 not null
+ ((and l1 l2) nil)
+ ;; l1 null and l2 null ==> l1 length = l2 length
+ ((and (null l1) (null l2)))
+ ;; l1 not null and l2 null ==> l1 length > l2 length
+ (l1 (zerop (version-list-not-zero l1)))
+ ;; l1 null and l2 not null ==> l2 length > l1 length
+ (t (zerop (version-list-not-zero l2)))))
+
+
+(defun version-list-<= (l1 l2)
+ "Return t if integer list L1 is lesser than or equal to L2.
+
+Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
+etc. That is, the trailing zeroes are irrelevant. Also, integer
+list (1) is greater than (1 -1) which is greater than (1 -2)
+which is greater than (1 -3)."
+ (while (and l1 l2 (= (car l1) (car l2)))
+ (setq l1 (cdr l1)
+ l2 (cdr l2)))
+ (cond
+ ;; l1 not null and l2 not null
+ ((and l1 l2) (< (car l1) (car l2)))
+ ;; l1 null and l2 null ==> l1 length = l2 length
+ ((and (null l1) (null l2)))
+ ;; l1 not null and l2 null ==> l1 length > l2 length
+ (l1 (<= (version-list-not-zero l1) 0))
+ ;; l1 null and l2 not null ==> l2 length > l1 length
+ (t (<= 0 (version-list-not-zero l2)))))
+
+(defun version-list-not-zero (lst)
+ "Return the first non-zero element of integer list LST.
+
+If all LST elements are zeroes or LST is nil, return zero."
+ (while (and lst (zerop (car lst)))
+ (setq lst (cdr lst)))
+ (if lst
+ (car lst)
+ ;; there is no element different of zero
+ 0))
+
+
+(defun version< (v1 v2)
+ "Return t if version V1 is lesser than V2.
+
+Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+etc. That is, the trailing \".0\"s are irrelevant. Also, version string \"1\"
+is greater than \"1pre\" which is greater than \"1beta\" which is greater than
+\"1alpha\"."
+ (version-list-< (version-to-list v1) (version-to-list v2)))
+
+
+(defun version<= (v1 v2)
+ "Return t if version V1 is lesser than or equal to V2.
+
+Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+etc. That is, the trailing \".0\"s are irrelevant. Also, version string \"1\"
+is greater than \"1pre\" which is greater than \"1beta\" which is greater than
+\"1alpha\"."
+ (version-list-<= (version-to-list v1) (version-to-list v2)))
+
+(defun version= (v1 v2)
+ "Return t if version V1 is equal to V2.
+
+Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+etc. That is, the trailing \".0\"s are irrelevant. Also, version string \"1\"
+is greater than \"1pre\" which is greater than \"1beta\" which is greater than
+\"1alpha\"."
+ (version-list-= (version-to-list v1) (version-to-list v2)))
+
+
;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc
;;; subr.el ends here