;;; subr.el --- basic lisp subroutines for Emacs
;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
(defmacro def-edebug-spec (symbol spec)
"Set the `edebug-form-spec' property of SYMBOL according to SPEC.
-Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol
+Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol
\(naming a function), or a list."
`(put (quote ,symbol) 'edebug-form-spec (quote ,spec)))
(list 'setq listname (list 'cdr listname)))))
(defmacro when (cond &rest body)
- "If COND yields non-nil, do BODY, else return nil."
+ "If COND yields non-nil, do BODY, else return nil.
+When COND yields non-nil, eval BODY forms sequentially and return
+value of last one, or nil if there are none.
+
+\(fn COND BODY...)"
(declare (indent 1) (debug t))
(list 'if cond (cons 'progn body)))
(defmacro unless (cond &rest body)
- "If COND yields nil, do BODY, else return nil."
+ "If COND yields nil, do BODY, else return nil.
+When COND yields nil, eval BODY forms sequentially and return
+value of last one, or nil if there are none.
+
+\(fn COND BODY...)"
(declare (indent 1) (debug t))
(cons 'if (cons cond (cons nil body))))
(if (integerp b) (< a b)
t)
(if (integerp b) t
+ ;; string< also accepts symbols.
(string< a b))))))
(dolist (p list)
(funcall function (car p) (cdr p))))
;;;; substitute-key-definition and its subroutines.
(defvar key-substitution-in-progress nil
- "Used internally by `substitute-key-definition'.")
+ "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.
(defun posn-set-point (position)
"Move point to POSITION.
Select the corresponding window as well."
- (if (not (windowp (posn-window position)))
- (error "Position not in text area of window"))
- (select-window (posn-window position))
- (if (numberp (posn-point position))
- (goto-char (posn-point position))))
+ (if (not (windowp (posn-window position)))
+ (error "Position not in text area of window"))
+ (select-window (posn-window position))
+ (if (numberp (posn-point position))
+ (goto-char (posn-point position))))
(defsubst posn-x-y (position)
"Return the x and y coordinates in POSITION.
(defsubst posn-image (position)
"Return the image object of POSITION.
-Value is an list (image ...), or nil if not an image.
+Value is a 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))
;;;; 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
+ '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")
;; Lisp manual only updated in 22.1.
(define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro
- "before 19.34")
+ "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")
+(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")
+(make-obsolete-variable 'x-sent-selection-hooks
+ 'x-sent-selection-functions "22.1")
(defvaralias 'messages-buffer-max-lines 'message-log-max)
\f
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."
+Major mode functions should use this instead of `run-hooks' when running their
+FOO-mode-hook."
(if delay-mode-hooks
;; Delaying case.
(dolist (hook hooks)
(when (featurep 'make-network-process)
(defun open-network-stream (name buffer host service)
- "Open a TCP connection for a service to a host.
+ "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.
HOST is name of the host to connect to, or its IP address.
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)))
+ (make-network-process :name name :buffer buffer
+ :host host :service service)))
;; compatibility
-(make-obsolete 'process-kill-without-query
- "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
- "22.1")
+(make-obsolete
+ 'process-kill-without-query
+ "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
+ "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.
'read-quoted-char-radix 8
"*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
Legitimate radix values are 8, 10 and 16."
- :type '(choice (const 8) (const 10) (const 16))
- :group 'editing-basics)
+ :type '(choice (const 8) (const 10) (const 16))
+ :group 'editing-basics)
(defun read-quoted-char (&optional prompt)
"Like `read-char', but do not allow quitting.
;; or C-q C-x might not return immediately since ESC or C-x might be
;; bound to some prefix in function-key-map or key-translation-map.
(setq translated char)
- (let ((translation (lookup-key function-key-map (vector char))))
+ (let ((translation (lookup-key local-function-key-map (vector char))))
(if (arrayp translation)
(setq translated (aref translation 0))))
(cond ((null translated))
;; This should be used by `call-interactively' for `n' specs.
(defun read-number (prompt &optional default)
+ "Read a numeric value in the minibuffer, prompting with PROMPT.
+DEFAULT specifies a default value to return if the user just types RET.
+The value of DEFAULT is inserted into PROMPT."
(let ((n nil))
(when default
(setq prompt
(let ((str (read-from-minibuffer prompt nil nil nil nil
(and default
(number-to-string default)))))
- (setq n (cond
- ((zerop (length str)) default)
- ((stringp str) (read str)))))
+ (condition-case nil
+ (setq n (cond
+ ((zerop (length str)) default)
+ ((stringp str) (read str))))
+ (error nil)))
(unless (numberp n)
(message "Please enter a number.")
(sit-for 1)
(defun momentary-string-display (string pos &optional exit-char message)
"Momentarily display STRING in the buffer at POS.
Display remains until next event is input.
+If POS is a marker, only its position is used; its buffer is ignored.
Optional third arg EXIT-CHAR can be a character, event or event
description list. EXIT-CHAR defaults to SPC. If the input is
EXIT-CHAR it is swallowed; otherwise it is then available as
input (as a command if nothing else).
Display MESSAGE (optional fourth arg) in the echo area.
If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
- (or exit-char (setq exit-char ?\ ))
+ (or exit-char (setq exit-char ?\s))
(let ((inhibit-read-only t)
;; Don't modify the undo list at all.
(buffer-undo-list t)
(progn
(save-excursion
(goto-char pos)
+ ;; To avoid trouble with out-of-bounds position
+ (setq pos (point))
;; defeat file locking... don't try this at home, kids!
(setq buffer-file-name nil)
(insert-before-markers string)
(put 'cl-assertion-failed 'error-conditions '(error))
(put 'cl-assertion-failed 'error-message "Assertion failed")
+(defconst user-emacs-directory
+ (if (eq system-type 'ms-dos)
+ ;; MS-DOS cannot have initial dot.
+ "~/_emacs.d/"
+ "~/.emacs.d/")
+ "Directory beneath which additional per-user Emacs-specific files are placed.
+Various programs in Emacs store information in this directory.
+Note that this should end with a directory separator.")
+
\f
;;;; Misc. useful functions.
(get-text-property 0 'yank-handler string)))
(param (or (nth 1 handler) string))
(opoint (point))
+ (inhibit-read-only inhibit-read-only)
end)
(setq yank-undo-function t)
(insert param))
(setq end (point))
+ ;; Prevent read-only properties from interfering with the
+ ;; following text property changes.
+ (setq inhibit-read-only t)
+
;; What should we do with `font-lock-face' properties?
(if font-lock-defaults
;; No, just wipe them.
(text-properties-at (1- end)))
(put-text-property (1- end) end 'rear-nonsticky t))
- (if (eq yank-undo-function t) ;; not set by FUNCTION
+ (if (eq yank-undo-function t) ;; not set by FUNCTION
(setq yank-undo-function (nth 3 handler))) ;; UNDO
- (if (nth 4 handler) ;; COMMAND
+ (if (nth 4 handler) ;; COMMAND
(setq this-command (nth 4 handler)))))
(defun insert-buffer-substring-no-properties (buffer &optional start end)
(start-process name buffer shell-file-name shell-command-switch
(mapconcat 'identity args " ")))))
+(defun start-file-process-shell-command (name buffer &rest args)
+ "Start a program in a subprocess. Return the process object for it.
+Similar to `start-process-shell-command', but calls `start-file-process'."
+ (start-file-process
+ name buffer
+ (if (file-remote-p default-directory) "/bin/sh" shell-file-name)
+ (if (file-remote-p default-directory) "-c" shell-command-switch)
+ (mapconcat 'identity args " ")))
+
(defun call-process-shell-command (command &optional infile buffer display
&rest args)
"Execute the shell command COMMAND synchronously in separate process.
infile buffer display
shell-command-switch
(mapconcat 'identity (cons command args) " ")))))
+
+(defun process-file-shell-command (command &optional infile buffer display
+ &rest args)
+ "Process files synchronously in a separate process.
+Similar to `call-process-shell-command', but calls `process-file'."
+ (process-file
+ (if (file-remote-p default-directory) "/bin/sh" shell-file-name)
+ infile buffer display
+ (if (file-remote-p default-directory) "-c" shell-command-switch)
+ (mapconcat 'identity (cons command args) " ")))
\f
;;;; Lisp macros to do various things temporarily.
(if (window-live-p save-selected-window-window)
(select-window save-selected-window-window 'norecord))))))
+(defmacro with-selected-frame (frame &rest body)
+ "Execute the forms in BODY with FRAME as the selected frame.
+The value returned is the value of the last form in BODY.
+See also `with-temp-buffer'."
+ (declare (indent 1) (debug t))
+ (let ((old-frame (make-symbol "old-frame"))
+ (old-buffer (make-symbol "old-buffer")))
+ `(let ((,old-frame (selected-frame))
+ (,old-buffer (current-buffer)))
+ (unwind-protect
+ (progn (select-frame ,frame)
+ ,@body)
+ (if (frame-live-p ,old-frame)
+ (select-frame ,old-frame))
+ (if (buffer-live-p ,old-buffer)
+ (set-buffer ,old-buffer))))))
+
(defmacro with-temp-file (file &rest body)
"Create a new buffer, evaluate BODY there, and write the buffer to FILE.
The value returned is the value of the last form in BODY.
(or (input-pending-p)
,@body))))))
+(defmacro condition-case-no-debug (var bodyform &rest handlers)
+ "Like `condition-case' except that it does not catch anything when debugging.
+More specifically if `debug-on-error' is set, then it does not catch any signal."
+ (declare (debug condition-case) (indent 2))
+ (let ((bodysym (make-symbol "body")))
+ `(let ((,bodysym (lambda () ,bodyform)))
+ (if debug-on-error
+ (funcall ,bodysym)
+ (condition-case ,var
+ (funcall ,bodysym)
+ ,@handlers)))))
+
+(defmacro with-demoted-errors (&rest body)
+ "Run BODY and demote any errors to simple messages.
+If `debug-on-error' is non-nil, run BODY without catching its errors.
+This is to be used around code which is not expected to signal an error
+but which should be robust in the unexpected case that an error is signalled."
+ (declare (debug t) (indent 0))
+ (let ((err (make-symbol "err")))
+ `(condition-case-no-debug ,err
+ (progn ,@body)
+ (error (message "Error: %s" ,err) nil))))
+
(defmacro combine-after-change-calls (&rest body)
"Execute BODY, but don't call the after-change functions till the end.
If BODY makes changes in the buffer, they are recorded
(let ((combine-after-change-calls t))
. ,body)
(combine-after-change-execute)))
+
+(defmacro with-case-table (table &rest body)
+ "Execute the forms in BODY with TABLE as the current case table.
+The value returned is the value of the last form in BODY."
+ (declare (indent 1) (debug t))
+ (let ((old-case-table (make-symbol "table"))
+ (old-buffer (make-symbol "buffer")))
+ `(let ((,old-case-table (current-case-table))
+ (,old-buffer (current-buffer)))
+ (unwind-protect
+ (progn (set-case-table ,table)
+ ,@body)
+ (with-current-buffer ,old-buffer
+ (set-case-table ,old-case-table))))))
\f
;;;; Constructing completion tables.
+(defun complete-with-action (action table string pred)
+ "Perform completion ACTION.
+STRING is the string to complete.
+TABLE is the completion table, which should not be a function.
+PRED is a completion predicate.
+ACTION can be one of nil, t or `lambda'."
+ ;; (assert (not (functionp table)))
+ (funcall
+ (cond
+ ((null action) 'try-completion)
+ ((eq action t) 'all-completions)
+ (t 'test-completion))
+ string table pred))
+
(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,
(with-current-buffer (let ((,win (minibuffer-selected-window)))
(if (window-live-p ,win) (window-buffer ,win)
(current-buffer)))
- (cond
- ((eq ,mode t) (all-completions ,string (,fun ,string) ,predicate))
- ((not ,mode) (try-completion ,string (,fun ,string) ,predicate))
- (t (test-completion ,string (,fun ,string) ,predicate)))))))
+ (complete-with-action ,mode (,fun ,string) ,string ,predicate)))))
(defmacro lazy-completion-table (var fun)
;; We used to have `&rest args' where `args' were evaluated late (at the
(looking-at (concat "\\(?:" regexp "\\)\\'")))))
(not (null pos))))
+(defsubst looking-at-p (regexp)
+ "\
+Same as `looking-at' except this function does not change the match data."
+ (let ((inhibit-changing-match-data t))
+ (looking-at regexp)))
+
+(defsubst string-match-p (regexp string &optional start)
+ "\
+Same as `string-match' except this function does not change the match data."
+ (let ((inhibit-changing-match-data t))
+ (string-match regexp string start)))
+
(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.
which correctly parses CSV format, for example.
Note that the effect of `(split-string STRING)' is the same as
-`(split-string STRING split-string-default-separators t)'). In the rare
+`(split-string STRING split-string-default-separators t)'. In the rare
case that you wish to retain zero-length substrings when splitting on
whitespace, use `(split-string STRING split-string-default-separators)'.
(cons (substring string start)
list)))
(nreverse list)))
+
+;; (string->strings (strings->string X)) == X
+(defun strings->string (strings &optional separator)
+ "Concatenate the STRINGS, adding the SEPARATOR (default \" \").
+This tries to quote the strings to avoid ambiguity such that
+ (string->strings (strings->string strs)) == strs
+Only some SEPARATORs will work properly."
+ (let ((sep (or separator " ")))
+ (mapconcat
+ (lambda (str)
+ (if (string-match "[\\\"]" str)
+ (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"")
+ str))
+ strings sep)))
+
+;; (string->strings (strings->string X)) == X
+(defun string->strings (string &optional separator)
+ "Split the STRING into a list of strings.
+It understands elisp style quoting within STRING such that
+ (string->strings (strings->string strs)) == strs
+The SEPARATOR regexp defaults to \"\\s-+\"."
+ (let ((sep (or separator "\\s-+"))
+ (i (string-match "[\"]" string)))
+ (if (null i) (split-string string sep t) ; no quoting: easy
+ (append (unless (eq i 0) (split-string (substring string 0 i) sep t))
+ (let ((rfs (read-from-string string i)))
+ (cons (car rfs)
+ (string->strings (substring string (cdr rfs))
+ sep)))))))
+
\f
;;;; Replacement in strings.
newstr))
(defun replace-regexp-in-string (regexp rep string &optional
- fixedcase literal subexp start)
+ fixedcase literal subexp start)
"Replace all matches for REGEXP with REP in STRING.
Return a new string containing the replacements.
rep
(funcall rep (match-string 0 str)))
fixedcase literal str subexp)
- (cons (substring string start mb) ; unmatched prefix
+ (cons (substring string start mb) ; unmatched prefix
matches)))
(setq start me))
;; Reconstruct a string from the pieces.
(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))))
+ (setq buffer-invisibility-spec
+ (delete element buffer-invisibility-spec))))
\f
;;;; Syntax tables.
(defvar version-regexp-alist
'(("^[-_+ ]?a\\(lpha\\)?$" . -3)
- ("^[-_+]$" . -3) ; treat "1.2.3-20050920" and "1.2-3" as alpha releases
+ ("^[-_+]$" . -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))
;; Change .x.y to 0.x.y
(if (and (>= (length ver) (length version-separator))
(string-equal (substring ver 0 (length version-separator))
- version-separator))
+ version-separator))
(setq ver (concat "0" ver)))
(save-match-data
(let ((i 0)